From 188873f068b0c53febe4ee0ededbc755fce4869d Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 28 May 2004 19:02:33 +0000 Subject: [PATCH] r9507: rrf updates --- Makefile | 3 +- class-support.lisp | 11 ++- create-sql.lisp | 34 ++++--- data-structures.lisp | 8 +- parse-common.lisp | 63 ++++++++---- parse-macros.lisp | 84 +++++++++++----- parse-2002.lisp => parse-rrf.lisp | 153 +++++++++++++----------------- sql-classes.lisp | 21 ++-- sql.lisp | 6 +- tests/.gitignore | 1 + tests/basic.lisp | 152 ++++++++++++++--------------- tests/init.lisp | 35 +++++++ tests/package.lisp | 5 +- tests/parse.lisp | 86 ++++++++++------- umlisp-tests.asd | 12 ++- umlisp.asd | 12 +-- utils.lisp | 29 +++++- 17 files changed, 422 insertions(+), 293 deletions(-) rename parse-2002.lisp => parse-rrf.lisp (68%) create mode 100644 tests/.gitignore create mode 100644 tests/init.lisp diff --git a/Makefile b/Makefile index dfa7a11..c63e1bf 100644 --- a/Makefile +++ b/Makefile @@ -1,8 +1,9 @@ -.PHONY: all clean test test-acl test-sbcl +.PHONY: all clean test test-acl test-sbcl distclean test-file:=`pwd`/run-tests.lisp all: +distclean: clean clean: @find . -type f -name "*.fasl*" -or -name "*.ufsl" -or -name "*.x86f" \ -or -name "*.fas" -or -name "*.pfsl" -or -name "*.dfsl" \ diff --git a/class-support.lisp b/class-support.lisp index 89dbd6e..208e1a3 100644 --- a/class-support.lisp +++ b/class-support.lisp @@ -66,7 +66,16 @@ (defmethod fmt-tui ((tui string)) (if (eql (aref tui 0) #\T) tui - (fmt-tui (parse-integer tui)))) + (fmt-tui (parse-integer tui)))) + +(defgeneric fmt-aui (aui)) +(defmethod fmt-aui ((aui fixnum)) + (prefixed-fixnum-string aui #\A 7)) + +(defmethod fmt-aui ((aui string)) + (if (eql (aref aui 0) #\A) + aui + (fmt-aui (parse-integer aui)))) (defgeneric fmt-eui (e)) (defmethod fmt-eui ((e fixnum)) diff --git a/create-sql.lisp b/create-sql.lisp index 6e50a0f..4978843 100644 --- a/create-sql.lisp +++ b/create-sql.lisp @@ -23,13 +23,21 @@ (let ((col-func (lambda (c) (let ((sqltype (sqltype c))) + (case *umls-sql-type* + (:oracle + (cond + ((string-equal sqltype "VARCHAR") + (setq sqltype "VARCHAR2")) + ((string-equal sqltype "BIGINT") + (setq sqltype "VARCHAR2(20)"))))) + (concatenate 'string - (col c) - " " - (if (or (string-equal sqltype "VARCHAR") - (string-equal sqltype "CHAR")) - (format nil "~a (~a)" sqltype (cmax c)) - sqltype)))))) + (col c) + " " + (if (or (string-equal sqltype "VARCHAR") + (string-equal sqltype "CHAR")) + (format nil "~a (~a)" sqltype (cmax c)) + sqltype)))))) (format nil "CREATE TABLE ~a (~{~a~^,~})" (table file) (mapcar col-func (ucols file))))) @@ -93,9 +101,9 @@ (defun noneng-lang-index-files () (remove-if-not (lambda (f) (and (> (length (fil f)) 4) - (string-equal (fil f) "MRXW." :end1 5) - (not (string-equal (fil f) "MRXW.ENG")) - (not (string-equal (fil f) "MRXW.NONENG")))) + (string-equal (fil f) "MRXW_" :end1 5) + (not (string-equal (fil f) "MRXW_ENG.RRF")) + (not (string-equal (fil f) "MRXW_NONENG.RRF")))) *umls-files*)) ;;; SQL Command Functions @@ -221,7 +229,7 @@ This is much faster that using create-umls-db-insert." (defun translate-all-files (&optional (extension ".trans")) "Copy translated files and return postgresql copy commands to import" (make-noneng-index-file extension) - (dolist (f (remove "MRXW.NONENG" *umls-files* :test #'string= :key #'fil)) + (dolist (f (remove "MRXW_NONENG.RRF" *umls-files* :test #'string= :key #'fil)) (translate-umls-file f extension))) (defun translate-umls-file (file extension) @@ -230,17 +238,17 @@ This is much faster that using create-umls-db-insert." (defun make-noneng-index-file (extension) "Make non-english index file" - (translate-files (find-ufile "MRXW.NONENG") + (translate-files (find-ufile "MRXW_NONENG.RRF") extension (noneng-lang-index-files))) (defun translate-files (out-ufile extension input-ufiles) "Translate a umls file into a format suitable for sql copy cmd" - (let ((output-path (umls-pathname (fil out-ufile) extension))) + (let ((output-path (ufile-pathname out-ufile extension))) (if (probe-file output-path) (format t "File ~A already exists: skipping~%" output-path) (with-open-file (ostream output-path :direction :output) (dolist (input-ufile input-ufiles) - (with-umls-file (line (fil input-ufile)) + (with-umls-ufile (line input-ufile) (translate-line out-ufile line ostream) (princ #\newline ostream))))))) diff --git a/data-structures.lisp b/data-structures.lisp index 7652fc8..beb209a 100644 --- a/data-structures.lisp +++ b/data-structures.lisp @@ -21,7 +21,7 @@ ;;; Paths for files (defvar *umls-path* - (make-pathname :directory '(:absolute "data" "umls" "2003AC")) + (make-pathname :directory '(:absolute "data" "umls" "2004AA")) "Path for base of UMLS data files") (defvar *meta-path* @@ -54,7 +54,9 @@ ;; Preliminary objects to replace structures (defclass ufile () - ((fil :initarg :fil :accessor fil) + ((subdir :initarg :subdir :accessor subdir) + (dir :initarg :dir :accessor dir) + (fil :initarg :fil :accessor fil) (table :initarg :table :accessor table) (des :initarg :des :accessor des) (fmt :initarg :fmt :accessor fmt) @@ -64,7 +66,7 @@ (fields :initarg :fields :accessor fields) (ucols :initarg :ucols :accessor ucols)) (:default-initargs :fil nil :table nil :des nil :fmt nil :cls nil :rws nil :bts nil - :fields nil :ucols nil) + :fields nil :ucols nil :subdir nil :dir nil) (:documentation "UMLS File")) (defclass ucol () diff --git a/parse-common.lisp b/parse-common.lisp index 98d0c01..c603236 100644 --- a/parse-common.lisp +++ b/parse-common.lisp @@ -19,8 +19,10 @@ (in-package #:umlisp) (defun ensure-ucols+ufiles (&optional (alwaysclear nil)) -"Initialize all UMLS file and column structures if not already initialized" + "Initialize all UMLS file and column structures if not already initialized" (when (or alwaysclear (null *umls-files*)) + (setq *umls-cols* nil) + (setq *umls-files* nil) (gen-ucols) (gen-ufiles) (ensure-field-lengths))) @@ -35,6 +37,16 @@ (setq *umls-files* (append (mklist ufiles) *umls-files*)) ufiles) +(defun ufile-pathname (ufile &optional (extension "")) + "Return pathname for a umls filename with an optional extension" + (assert (typep ufile 'ufile)) + (let ((dirs (append (list (dir ufile)) + (awhen (subdir ufile) (list it))))) + (merge-pathnames + (make-pathname :name (concatenate 'string (fil ufile) extension) + :directory (cons :relative dirs)) + *umls-path*))) + (defun umls-pathname (filename &optional (extension "")) "Return pathname for a umls filename with an optional extension" (etypecase filename @@ -51,14 +63,8 @@ (t *umls-path*)))) (pathname - filename))) + filename))) -(defun read-umls-line (strm &optional (eof 'eof)) - "Read a line from a UMLS stream, split into fields" - (let ((line (read-line strm nil eof))) - (if (eq line eof) - eof - (delimited-string-to-list line #\| t)))) ;;; Find field lengths for LEX and NET files @@ -89,18 +95,18 @@ Currently, these are the LEX and NET files." (loop for ufile in *umls-files* unless (or (char= #\M (schar (fil ufile) 0)) (char= #\m (schar (fil ufile) 0))) - collect ufile)) + collect ufile)) (defun ufiles-field-lengths (ufiles) "Returns a list of lists of containing (FILE MAX AV)" - (loop for ufile in ufiles collect (file-field-lengths (fil ufile)))) + (loop for ufile in ufiles collect (file-field-lengths ufile))) -(defun file-field-lengths (filename) +(defun file-field-lengths (ufile) "Returns a list of FILENAME MAX AV" (declare (optimize (speed 3) (safety 0))) (let (fields-max fields-av num-fields (count-lines 0)) - (with-umls-file (line filename) + (with-umls-ufile (line ufile) (unless num-fields (setq num-fields (length line)) (setq fields-max (make-array num-fields :element-type 'fixnum @@ -116,7 +122,7 @@ Currently, these are the LEX and NET files." (incf count-lines)) (dotimes (i num-fields) (setf (aref fields-av i) (float (/ (aref fields-av i) count-lines)))) - (list filename fields-max fields-av))) + (list (fil ufile) fields-max fields-av))) ;;; UMLS column/file functions @@ -177,7 +183,9 @@ Currently, these are the LEX and NET files." :col col :des des :ref ref :min min :av av :max (if (eql max 0) 1 max) ;; ensure at least one char wide :fil fil - :dty dty :sqltype sqltype :quote-str quote-str + :dty dty + :sqltype sqltype + :quote-str quote-str :parse-fun (ensure-compiled-fun parse-fun) :custom-value-fun (ensure-compiled-fun custom-value-fun)))) (ensure-ucol-datatype ucol (datatype-for-colname col)) @@ -215,11 +223,28 @@ append a unique number (starting at 2) onto a column name that is repeated in th (setf (gethash colname col-counts) 1) colname)))))) -(defun make-ufile (fil des table cls rws bts fields) - (let ((ufile (make-instance 'ufile :fil fil :des des :table table :cls cls - :rws rws :bts bts :fields fields))) - (setf (ucols ufile) (find-ucols-for-ufile ufile)) - ufile)) +(defun decompose-fil (fil) + (if fil + (let ((pos (position #\/ fil))) + (if pos + (values (subseq fil (1+ pos)) (subseq fil 0 pos)) + (values fil nil))) + (values nil nil))) + +(defun filename-to-tablename (file) + (let ((pos (search ".RRF" file))) + (when pos + (setf file (subseq file 0 pos)))) + (substitute #\_ #\. file)) + +(defun make-ufile (dir fil des cls rws bts fields) + (multiple-value-bind (file subdir) (decompose-fil fil) + (let ((ufile (make-instance 'ufile :dir dir :fil file :subdir subdir + :des des :cls cls + :rws rws :bts bts :fields fields + :table (filename-to-tablename file)))) + (setf (ucols ufile) (find-ucols-for-ufile ufile)) + ufile))) (defun datatype-for-colname (colname) "Return datatype for column name" diff --git a/parse-macros.lisp b/parse-macros.lisp index e71ba1d..a775b0f 100644 --- a/parse-macros.lisp +++ b/parse-macros.lisp @@ -18,17 +18,66 @@ (in-package #:umlisp) -(defmacro with-umls-file ((line filename) &body body) -"Opens a UMLS and processes each parsed line with (body) argument" +(defun read-umls-line (strm &optional (eof 'eof)) + "Read a line from a UMLS stream, split into fields" + (let ((line (read-line strm nil eof))) + (if (eq line eof) + eof + (delimited-string-to-list line #\| t)))) + +(defun source-files (path) + (if (probe-file path) + (list path) + (sort + (directory (make-pathname :defaults path + :type :wild + :name (concatenate 'string (pathname-name path) + (aif (pathname-type path) + (concatenate 'string "." it) + "")))) + #'(lambda (a b) + (string-lessp (pathname-type a) (pathname-type b)))))) + +(defmacro with-buffered-reading-umls-file ((line path) &body body) + "Opens a UMLS and processes each parsed line with (body) argument" (let ((ustream (gensym "STRM-")) - (eof (gensym "EOF-"))) - `(let ((,eof (gensym "EOFSYM-"))) - (with-open-file - (,ustream (umls-pathname ,filename) :direction :input) - (do ((,line (read-umls-line ,ustream ,eof) - (read-umls-line ,ustream ,eof))) - ((eq ,line ,eof) t) - ,@body))))) + (buffer (gensym "BUF-")) + (eof (gensym "EOF-")) + (files (gensym "FILES-"))) + `(let ((,eof (gensym "EOFSYM-")) + (,buffer (make-fields-buffer)) + (,files (source-files ,path))) + (with-open-file (,ustream (first ,files) :direction :input) + (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof) + (read-buffered-fields ,buffer ,ustream #\| ,eof))) + ((eq ,line ,eof) t) + (setq ,line (coerce ,line 'list)) + (print ,line) + ,@body))))) + +(defmacro with-reading-umls-file ((line path) &body body) + "Opens a UMLS and processes each parsed line with (body) argument" + (let ((ustream (gensym "STRM-")) + (eof (gensym "EOF-")) + (files (gensym "FILES-"))) + `(let ((,eof (gensym "EOFSYM-")) + (,files (source-files ,path))) + (with-open-file (,ustream (first ,files) :direction :input) + (do ((,line (read-umls-line ,ustream ,eof) + (read-umls-line ,ustream ,eof))) + ((eq ,line ,eof) t) + ,@body))))) + +(defmacro with-umls-ufile ((line ufile) &body body) + "Opens a UMLS and processes each parsed line with (body) argument" + `(with-reading-umls-file (,line (ufile-pathname ,ufile)) + ,@body)) + +(defmacro with-umls-file ((line ufile) &body body) + "Opens a UMLS and processes each parsed line with (body) argument" + "Opens a UMLS and processes each parsed line with (body) argument" + `(with-reading-umls-file (,line (umls-pathname ,ufile)) + ,@body)) (defmacro with-buffered-umls-file ((line filename) &body body) "Opens a UMLS and processes each parsed line with (body) argument" @@ -44,17 +93,4 @@ ((eq ,line ,eof) t) ,@body))))) -(defmacro with-buffered2-umls-file ((line filename) &body body) - "Opens a UMLS and processes each parsed line with (body) argument" - (let ((ustream (gensym "STRM-")) - (buffer (gensym "BUF-")) - (eof (gensym "EOF-"))) - `(let ((,buffer (make-fields-buffer2)) - (,eof (gensym "EOFSYM-"))) - (with-open-file - (,ustream (umls-pathname ,filename) - :direction :input :if-exists :overwrite) - (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof) - (read-buffered-fields ,buffer ,ustream #\| ,eof))) - ((eq ,line ,eof) t) - ,@body))))) + diff --git a/parse-2002.lisp b/parse-rrf.lisp similarity index 68% rename from parse-2002.lisp rename to parse-rrf.lisp index dd10ac0..8b13b3a 100644 --- a/parse-2002.lisp +++ b/parse-rrf.lisp @@ -44,51 +44,28 @@ cuisui-lrl-hash (make-hash-table :size 1800000) sab-srl-hash (make-hash-table :size 100 :test 'equal)))) - (defun buffered-ensure-preparse (&optional (force-read nil)) - (when (or force-read (not *preparse-hash-init?*)) - (make-preparse-hash-table) - (setq *preparse-hash-init?* t)) - (with-buffered-umls-file (line "MRCON") - (let ((cui (parse-ui (aref line 0))) - (lui (parse-ui (aref line 3))) - (sui (parse-ui (aref line 5))) - (lrl (parse-integer (aref line 7)))) - (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui - (if (and (string-equal (aref line 1) "ENG") ; LAT - (string-equal (aref line 2) "P") ; ts - (string-equal (aref line 4) "PF")) ; stt - (setf (gethash cui pfstr-hash) (aref line 6)))) - (set-lrl-hash cui lrl cui-lrl-hash) - (set-lrl-hash lui lrl lui-lrl-hash) - (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash))) - (with-buffered-umls-file (line "MRSO") - (let ((sab (aref line 3))) - (unless (gethash sab sab-srl-hash) ;; if haven't stored - (setf (gethash sab sab-srl-hash) (aref line 6)))))) - (defun ensure-preparse (&optional (force-read nil)) (when (or force-read (not *preparse-hash-init?*)) (make-preparse-hash-table) (setq *preparse-hash-init?* t)) - (with-umls-file (line "MRCON") + (with-umls-file (line "MRCONSO.RRF") (let ((cui (parse-ui (nth 0 line))) (lui (parse-ui (nth 3 line))) (sui (parse-ui (nth 5 line))) - (lrl (parse-integer (nth 7 line)))) + (sab (nth 11 line)) + (srl (parse-integer (nth 15 line)))) (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui (if (and (string-equal (nth 1 line) "ENG") ; LAT (string-equal (nth 2 line) "P") ; ts (string-equal (nth 4 line) "PF")) ; stt - (setf (gethash cui pfstr-hash) (nth 6 line)))) - (set-lrl-hash cui lrl cui-lrl-hash) - (set-lrl-hash lui lrl lui-lrl-hash) - (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash))) - (with-umls-file (line "MRSO") - (let ((sab (nth 3 line))) - (multiple-value-bind (val found) (gethash sab sab-srl-hash) - (declare (ignore val)) - (unless found - (setf (gethash sab sab-srl-hash) (parse-integer (nth 6 line)))))))) + (setf (gethash cui pfstr-hash) (nth 14 line)))) + (set-lrl-hash cui srl cui-lrl-hash) + (set-lrl-hash lui srl lui-lrl-hash) + (set-lrl-hash (make-cuisui cui sui) srl cuisui-lrl-hash) + (multiple-value-bind (val found) (gethash sab sab-srl-hash) + (declare (ignore val)) + (unless found + (setf (gethash sab sab-srl-hash) srl)))))) (defun pfstr-hash (cui) (gethash cui pfstr-hash)) @@ -123,6 +100,7 @@ (defparameter +col-datatypes+ '(("AV" sql-f) ("BTS" sql-i) ("CLS" sql-i) ("COF" sql-i) ("CUI1" sql-u) + ("AUI" sql-u) ("AUI1" sql-u) ("AUI2" sql-u) ("CUI2" sql-u) ("CUI" sql-u) ("CXN" sql-s) ("FR" sql-i) ("LRL" sql-s) ("LUI" sql-u) ("MAX" sql-s) ("MIN" sql-s) ("RANK" sql-s) ("REF" sql-c) ("RNK" sql-s) ("RWS" sql-i) ("SRL" sql-s) ("SUI" sql-u) ("TUI" sql-u) @@ -140,94 +118,91 @@ (defparameter +custom-tables+ nil - #+ignore - '(("MRCONSO" "SELECT m.CUI, m.LAT, m.TS, m.LUI, m.STT, m.SUI, m.STR, m.LRL, s.SAB, s.TTY, s.SCD, s.SRL FROM MRCON m, MRSO s WHERE m.CUI=s.CUI AND m.LUI=s.LUI AND m.SUI=s.SUI") - ("MRCONFULL" "SELECT m.CUI, m.LAT, m.TS, m.LUI, m.STT, m.SUI, m.STR, m.LRL, s.SAB, s.TTY, s.SCD, s.SRL, t.TUI FROM MRCON m, MRSO s, MRSTY t WHERE m.CUI=s.CUI AND m.LUI=s.LUI AND m.SUI=s.SUI AND m.CUI=t.CUI AND s.CUI=t.CUI")) "Custom tables to create") (defparameter +custom-cols+ - '(("MRCON" "KPFSTR" "TEXT" 1024 + '(("MRCONSO.RRF" "KPFSTR" "TEXT" 1024 (lambda (x) (pfstr-hash (parse-ui (nth 0 x))))) - ("MRCON" "KCUISUI" "BIGINT" 0 + ("MRCONSO.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 5 x)))))) - ("MRCON" "KCUILUI" "BIGINT" 0 + ("MRCONSO.RRF" "KCUILUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 3 x)))))) - ("MRCON" "KCUILRL" "INTEGER" 0 + ("MRCONSO.RRF" "KCUILRL" "INTEGER" 0 (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x)))))) - ("MRCON" "KLUILRL" "INTEGER" 0 + ("MRCONSO.RRF" "KLUILRL" "INTEGER" 0 (lambda (x) (write-to-string (lui-lrl (parse-ui (nth 3 x)))))) - ("MRLO" "KLRL" "INTEGER" 0 + ;; Deprecated, last in 2004AA -- skip index + #+ignore + ("MRLO.RRF" "KLRL" "INTEGER" 0 (lambda (x) (write-to-string (if (zerop (length (nth 4 x))) (cui-lrl (parse-ui (nth 0 x))) (cuisui-lrl (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 4 x)))))))) - ("MRSTY" "KLRL" "INTEGER" 0 + ("MRSTY.RRF" "KLRL" "INTEGER" 0 (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x)))))) - ("MRCOC" "KLRL" "INTEGER" 0 + ("MRCOC.RRF" "KLRL" "INTEGER" 0 (lambda (x) (write-to-string (max (cui-lrl (parse-ui (nth 0 x))) (kmrcl:aif (cui-lrl (parse-ui (nth 1 x))) kmrcl::it 0))))) - ("MRSAT" "KSRL" "INTEGER" 0 - (lambda (x) (write-to-string (sab-srl (nth 5 x))))) - ("MRREL" "KSRL" "INTEGER" 0 - (lambda (x) (write-to-string (sab-srl (nth 4 x))))) - ("MRRANK" "KSRL" "INTEGER" 0 - (lambda (x) (write-to-string (sab-srl (nth 1 x))))) - ("MRDEF" "KSRL" "INTEGER" 0 + ("MRSAT.RRF" "KSRL" "INTEGER" 0 + (lambda (x) (write-to-string (sab-srl (nth 9 x))))) + ("MRREL.RRF" "KSRL" "INTEGER" 0 + (lambda (x) (write-to-string (sab-srl (nth 10 x))))) + ("MRRANK.RRF" "KSRL" "INTEGER" 0 (lambda (x) (write-to-string (sab-srl (nth 1 x))))) - ("MRCXT" "KSRL" "INTEGER" 0 + ("MRDEF.RRF" "KSRL" "INTEGER" 0 + (lambda (x) (write-to-string (sab-srl (nth 4 x))))) + ("MRCXT.RRF" "KSRL" "INTEGER" 0 (lambda (x) (write-to-string (sab-srl (nth 2 x))))) - ("MRATX" "KSRL" "INTEGER" 0 + ("MRATX.RRF" "KSRL" "INTEGER" 0 (lambda (x) (write-to-string (sab-srl (nth 1 x))))) - ("MRXW.ENG" "KLRL" "INTEGER" 0 + ("MRXW_ENG.RRF" "KLRL" "INTEGER" 0 (lambda (x) (write-to-string (cuisui-lrl (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))) - ("MRXW.NONENG" "KLRL" "INTEGER" 0 + ("MRXW_NONENG.RRF" "KLRL" "INTEGER" 0 (lambda (x) (write-to-string (cuisui-lrl (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))) - ("MRXNW.ENG" "KLRL" "INTEGER" 0 + ("MRXNW_ENG.RRF" "KLRL" "INTEGER" 0 (lambda (x) (write-to-string (cuisui-lrl (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))) - ("MRXNS.ENG" "KLRL" "INTEGER" 0 + ("MRXNS_ENG.RRF" "KLRL" "INTEGER" 0 (lambda (x) (write-to-string (cuisui-lrl (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))) - ("MRREL" "KPFSTR2" "TEXT" 1024 + ("MRREL.RRF" "KPFSTR2" "TEXT" 1024 + (lambda (x) (pfstr-hash (parse-ui (nth 4 x))))) + ("MRCOC.RRF" "KPFSTR2" "TEXT" 1024 (lambda (x) (pfstr-hash (parse-ui (nth 2 x))))) - ("MRCOC" "KPFSTR2" "TEXT" 1024 - (lambda (x) (pfstr-hash (parse-ui (nth 1 x))))) - ("MRCXT" "KCUISUI" "BIGINT" 0 + ("MRCXT.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x)))))) - ("MRSAT" "KCUILUI" "BIGINT" 0 + ("MRSAT.RRF" "KCUILUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 1 x)))))) - ("MRSAT" "KCUISUI" "BIGINT" 0 - (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x)))))) - ("MRSO" "KCUISUI" "BIGINT" 0 + ("MRSAT.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x)))))) - ("MRXW.ENG" "KCUISUI" "BIGINT" 0 + ("MRXW_ENG.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))) - ("MRXNW.ENG" "KCUISUI" "BIGINT" 0 + ("MRXNW_ENG.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))) - ("MRXNS.ENG" "KCUISUI" "BIGINT" 0 + ("MRXNS_ENG.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))) - ("MRXW.NONENG" "LAT" "VARCHAR" 3 (lambda (x) (nth 0 x))) - ("MRXW.NONENG" "WD" "VARCHAR" 200 (lambda (x) (nth 1 x))) - ("MRXW.NONENG" "CUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 2 x))))) - ("MRXW.NONENG" "LUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 3 x))))) - ("MRXW.NONENG" "SUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 4 x))))) - ("MRXW.NONENG" "KCUISUI" "BIGINT" 0 + ("MRXW_NONENG.RRF" "LAT" "VARCHAR" 3 (lambda (x) (nth 0 x))) + ("MRXW_NONENG.RRF" "WD" "VARCHAR" 200 (lambda (x) (nth 1 x))) + ("MRXW_NONENG.RRF" "CUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 2 x))))) + ("MRXW_NONENG.RRF" "LUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 3 x))))) + ("MRXW_NONENG.RRF" "SUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 4 x))))) + ("MRXW_NONENG.RRF" "KCUISUI" "BIGINT" 0 (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))) "Custom columns to create.(filename, col, sqltype, value-func).") (defparameter +index-cols+ - '(("CUI" "MRATX") ("CUI1" "MRCOC") ("CUI" "MRCON") ("LUI" "MRCON") - ("LRL" "MRCON") - ("SUI" "MRCON") ("CUI" "MRCXT") ("CUI" "MRDEF") ("CUI" "MRLO") + '(("CUI" "MRATX") ("CUI1" "MRCOC") ("CUI" "MRCONSO") ("LUI" "MRCONSO") + ("SRL" "MRCONSO") ("AUI" "MRCONSO") + ("SUI" "MRCONSO") ("CUI" "MRCXT") ("CUI" "MRDEF") ("CUI" "MRLO") ("CUI1" "MRREL") ("CUI" "MRSAT") ("LUI" "MRSAT") ("SUI" "MRSAT") - ("CUI" "MRSO") ("SAB" "MRSO") ("SRL" "MRSO") ("CUI" "MRSTY") + ("CUI" "MRSTY") ("TUI" "MRSTY") ("CUI" "MRXNS_ENG") #+ignore ("NSTR" "MRXNS_ENG" 10) ("CUI" "MRXNW_ENG") ("NWD" "MRXNW_ENG") ("WD" "MRXW_ENG") @@ -238,7 +213,8 @@ ("KCUISUI" "MRXNS_ENG") ("KCUISUI" "MRXW_NONENG") ("KSRL" "MRATX") ("KSRL" "MRCXT") ("KSRL" "MRDEF") ("KSRL" "MRRANK") ("KSRL" "MRREL") ("KSRL" "MRSAT") ("KLRL" "MRCOC") - ("KLRL" "MRLO") ("KLRL" "MRSTY") ("KLRL" "MRXW_ENG") ("KLRL" "MRXNW_ENG") + #+ignore ("KLRL" "MRLO") ;; deprecated + ("KLRL" "MRSTY") ("KLRL" "MRXW_ENG") ("KLRL" "MRXNW_ENG") ("KLRL" "MRXNS_ENG") ("KLRL" "MRXW_NONENG") ;; LEX indices ("EUI" "LRABR") ("EUI2" "LRABR") ("EUI" "LRAGR") ("EUI" "LRCMP") ("EUI" "LRMOD") @@ -271,7 +247,7 @@ (defun gen-ucols-meta () "Initialize all umls columns" (let ((cols '())) - (with-umls-file (line "MRCOLS") + (with-umls-file (line "MRCOLS.RRF") (destructuring-bind (col des ref min av max fil dty) line (push (make-ucol col des ref (parse-integer min) (read-from-string av) (parse-integer max) fil dty) @@ -300,20 +276,21 @@ (defun gen-ufiles () - (add-ufiles (gen-ufiles-generic "MRFILES")) - (add-ufiles (gen-ufiles-generic "LRFIL")) - (add-ufiles (gen-ufiles-generic "SRFIL")) + (add-ufiles (gen-ufiles-generic "MRFILES.RRF" "META")) + (add-ufiles (gen-ufiles-generic "LRFIL" "LEX")) + (add-ufiles (gen-ufiles-generic "SRFIL" "NET")) ;; needs to come last (add-ufiles (gen-ufiles-custom))) -(defun gen-ufiles-generic (files-filename) +(defun gen-ufiles-generic (files-filename dir) "Initialize all LEX file structures" (let ((files '())) (with-umls-file (line files-filename) (destructuring-bind (fil des fmt cls rws bts) line (push (make-ufile - fil des (substitute #\_ #\. fil) (parse-integer cls) + dir fil des + (parse-integer cls) (parse-integer rws) (parse-integer bts) (concatenate 'list (umls-field-string-to-list fmt) (custom-colnames-for-filename fil))) @@ -321,8 +298,8 @@ (nreverse files))) (defun gen-ufiles-custom () - (make-ufile "MRXW.NONENG" "Custom NonEnglish Index" "MRXW_NONENG" - 5 0 0 (fields (find-ufile "MRXW.ENG")))) + (make-ufile "META" "MRXW_NONENG.RRF" "Custom NonEnglish Index" + 5 0 0 (fields (find-ufile "MRXW_ENG.RRF")))) diff --git a/sql-classes.lisp b/sql-classes.lisp index 2841201..a7b0804 100644 --- a/sql-classes.lisp +++ b/sql-classes.lisp @@ -41,15 +41,16 @@ ,%%fields ,@(when %%where (list %%where)) ,@(when %%where - `((typecase ,where-value - (fixnum - (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'")) - (number - (concatenate 'string "='" (write-to-string ,where-value) "'")) - (null - " is null") - (t - (format nil ,(if like "'%~A%'" "='~A'") ,where-value))))) + `((typecase ,where-value + #+ignore + (fixnum + (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'")) + (number + (concatenate 'string "='" (write-to-string ,where-value) "'")) + (null + " is null") + (t + (format nil ,(if like "'%~A%'" "='~A'") ,where-value))))) (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "") ,@(when %%order (list %%order)) ,@(when single (list " limit 1"))))) @@ -64,7 +65,7 @@ (if where-name (format nil (typecase where-value - (number "=~D") + (number "='~D'") (null " is null") (t (if like " like '%~A%""='~A'"))) diff --git a/sql.lisp b/sql.lisp index 863c9ef..7d2b0c6 100644 --- a/sql.lisp +++ b/sql.lisp @@ -19,10 +19,8 @@ (in-package #:umlisp) (defvar +umls-sql-map+ - '((:2002AD . "KUMLS2002AD") (:2003AA . "KUMLS2003AA") - (:2003AB . "KUMLS2003AB") (:2003AC . "KUMLS2003AC") - (:2004AA . "KUMLS2004AA"))) -(defvar +default-umls-db+ :2003AC) + '((:2004aa . "KUMLS2004AA"))) +(defvar +default-umls-db+ :2004aa) (defun lookup-db-name (db) diff --git a/tests/.gitignore b/tests/.gitignore new file mode 100644 index 0000000..ca8d09f --- /dev/null +++ b/tests/.gitignore @@ -0,0 +1 @@ +.bin diff --git a/tests/basic.lisp b/tests/basic.lisp index 8af9a66..2cfae73 100644 --- a/tests/basic.lisp +++ b/tests/basic.lisp @@ -18,86 +18,72 @@ (in-package #:umlisp-tests) -(deftest qs.1 (umlisp::query-string mrcon (cui lui)) - "select CUI,LUI from MRCON") - -(deftest qs.1e (umlisp::query-string-eval 'mrcon '(cui lui)) - "select CUI,LUI from MRCON") - -(deftest qs.2 (umlisp::query-string mrcon (cui lui) 0) - "select CUI,LUI from MRCON and KCUILRL<=0") - -(deftest qs.2e (umlisp::query-string-eval 'mrcon '(cui lui) 0) - "select CUI,LUI from MRCON and KCUILRL<=0") - -(deftest qs.3 (umlisp::query-string mrcon (cui lui) nil cui 5) - "select CUI,LUI from MRCON where CUI=5") - -(deftest qs.3e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'cui 5) - "select CUI,LUI from MRCON where CUI=5") - -(deftest qs.4 (umlisp::query-string mrcon (cui lui) nil kpfstr "Abc") - "select CUI,LUI from MRCON where KPFSTR='Abc'") - -(deftest qs.4e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'kpfstr "Abc") - "select CUI,LUI from MRCON where KPFSTR='Abc'") - -(deftest qs.5 (umlisp::query-string mrcon (cui lui) 2 cui 5 :single t) - "select CUI,LUI from MRCON where CUI=5 and KCUILRL<=2 limit 1") - -(deftest qs.5e (umlisp::query-string-eval 'mrcon '(cui lui) 2 'cui 5 :single t) - "select CUI,LUI from MRCON where CUI=5 and KCUILRL<=2 limit 1") - -(deftest qs.6 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :single t) - "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 limit 1") - -(deftest qs.6e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :single t) - "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 limit 1") - -(deftest qs.7 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :order (cui asc)) - "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc") - -(deftest qs.7e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :order '(cui asc)) - "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc") - -(deftest qs.8 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl - :order (cui asc def desc)) - "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc,DEF desc") - -(deftest qs.8e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl - :order '(cui asc def desc)) - "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc,DEF desc") - -(deftest ui.1 (umlisp::parse-cui "C0002341") 2341) -(deftest ui.2 (umlisp::parse-lui "L0002341") 2341) -(deftest ui.3 (umlisp::parse-sui "S0000000") 0) -(deftest ui.4 (umlisp::parse-tui "T123") 123) -(deftest ui.5 (fmt-cui 2341) "C0002341") -(deftest ui.6 (fmt-lui 2341) "L0002341") -(deftest ui.7 (fmt-sui 2341) "S0002341") -(deftest ui.8 (fmt-tui 231) "T231") -(deftest ui.9 (fmt-tui 231) "T231") -(deftest ui.10 (fmt-eui 231) "E0000231") -(deftest ui.11 (umlisp::make-cuisui 5 11) 50000011) -(deftest ui.12 (umlisp::decompose-cuisui 50000011) 5 11) -(deftest ui.13 (umlisp::parse-eui "E00002311") 2311) -(deftest ui.14 (umlisp::parse-lui "1234") 1234) -(deftest ui.15 (umlisp::parse-lui 1234) 1234) - -(defun f2 (&key (srl *current-srl*)) - "Return list of all ucon's" - (umlisp::with-umlisp-query ('mrcon (cui kpfstr kcuilrl) srl nil nil) - (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr - :lrl (ensure-integer kcuilrl)))) - -(defun f1 (&key (srl *current-srl*)) - "Return list of all ucon's" - (umlisp::with-sql-connection (db) - (clsql:map-query - 'list - #'(lambda (cui pfstr cuilrl) - (make-instance 'ucon :cui (ensure-integer cui) - :pfstr pfstr - :lrl (ensure-integer cuilrl))) - (umlisp::query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil) - :database db))) +(setq *rt-basic* + '( + (deftest :qrystr/1 (umlisp::query-string mrcon (cui lui)) + "select CUI,LUI from MRCON") + + (deftest :qrystr/1e (umlisp::query-string-eval 'mrcon '(cui lui)) + "select CUI,LUI from MRCON") + + (deftest :qrystr/2 (umlisp::query-string mrcon (cui lui) 0) + "select CUI,LUI from MRCON and KCUILRL<=0") + + (deftest :qrystr/2e (umlisp::query-string-eval 'mrcon '(cui lui) 0) + "select CUI,LUI from MRCON and KCUILRL<=0") + + (deftest :qrystr/3 (umlisp::query-string mrcon (cui lui) nil cui 5) + "select CUI,LUI from MRCON where CUI='5'") + + (deftest :qrystr/3e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'cui 5) + "select CUI,LUI from MRCON where CUI='5'") + + (deftest :qrystr/4 (umlisp::query-string mrcon (cui lui) nil kpfstr "Abc") + "select CUI,LUI from MRCON where KPFSTR='Abc'") + + (deftest :qrystr/4e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'kpfstr "Abc") + "select CUI,LUI from MRCON where KPFSTR='Abc'") + + (deftest :qrystr/5 (umlisp::query-string mrcon (cui lui) 2 cui 5 :single t) + "select CUI,LUI from MRCON where CUI='5' and KCUILRL<=2 limit 1") + + (deftest :qrystr/5e (umlisp::query-string-eval 'mrcon '(cui lui) 2 'cui 5 :single t) + "select CUI,LUI from MRCON where CUI='5' and KCUILRL<=2 limit 1") + + (deftest :qrystr/6 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :single t) + "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 limit 1") + + (deftest :qrystr/6e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :single t) + "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 limit 1") + + (deftest :qrystr/7 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :order (cui asc)) + "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 order by CUI asc") + + (deftest :qrystr/7e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :order '(cui asc)) + "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 order by CUI asc") + + (deftest :qrystr/8 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl + :order (cui asc def desc)) + "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 order by CUI asc,DEF desc") + + (deftest :qrystr/8e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl + :order '(cui asc def desc)) + "select SAB,DEF from MRDEF where CUI='39' and KSRL<=2 order by CUI asc,DEF desc") + + (deftest :ui/1 (umlisp::parse-cui "C0002341") 2341) + (deftest :ui/2 (umlisp::parse-lui "L0002341") 2341) + (deftest :ui/3 (umlisp::parse-sui "S0000000") 0) + (deftest :ui/4 (umlisp::parse-tui "T123") 123) + (deftest :ui/5 (fmt-cui 2341) "C0002341") + (deftest :ui/6 (fmt-lui 2341) "L0002341") + (deftest :ui/7 (fmt-sui 2341) "S0002341") + (deftest :ui/8 (fmt-tui 231) "T231") + (deftest :ui/9 (fmt-tui 231) "T231") + (deftest :ui/10 (fmt-eui 231) "E0000231") + (deftest :ui/11 (umlisp::make-cuisui 5 11) 50000011) + (deftest :ui/12 (umlisp::decompose-cuisui 50000011) 5 11) + (deftest :ui/13 (umlisp::parse-eui "E00002311") 2311) + (deftest :ui/14 (umlisp::parse-lui "1234") 1234) + (deftest :ui/15 (umlisp::parse-lui 1234) 1234) + + )) diff --git a/tests/init.lisp b/tests/init.lisp new file mode 100644 index 0000000..b49312f --- /dev/null +++ b/tests/init.lisp @@ -0,0 +1,35 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp-tests -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: basic.lisp +;;;; Purpose: Basic tests for UMLisp +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: May 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of UMLisp, is +;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. +;;;; +;;;; UMLisp users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License. +;;;; ************************************************************************* + +(in-package #:umlisp-tests) + +(defvar *rt-basic* nil) +(defvar *rt-parse* nil) +(defvar *error-count* 0) +(defvar *report-stream* *standard-output*) + +(setq regression-test::*catch-errors* nil) + +(defun run-tests () + (regression-test:rem-all-tests) + (dolist (test-form (append *rt-basic* *rt-parse*)) + (eval test-form)) + (let ((remaining (regression-test:do-tests *report-stream*))) + (when (regression-test:pending-tests) + (incf *error-count* (length remaining)))) + *error-count*) diff --git a/tests/package.lisp b/tests/package.lisp index 9c6985e..faa0c01 100644 --- a/tests/package.lisp +++ b/tests/package.lisp @@ -19,7 +19,8 @@ (in-package #:cl-user) (defpackage #:umlisp-tests - (:use #:umlisp #:cl #:rtest #:kmrcl)) + (:use #:umlisp #:cl #:rtest #:kmrcl) + (:export #:run-tests)) + -(setf rtest::*catch-errors* nil) diff --git a/tests/parse.lisp b/tests/parse.lisp index 14126be..c7a42e0 100644 --- a/tests/parse.lisp +++ b/tests/parse.lisp @@ -19,39 +19,59 @@ (in-package #:umlisp-tests) (eval-when (:compile-toplevel :load-toplevel :execute) - (if (probe-file (umlisp::umls-pathname "MRFILES")) - (pushnew :umls-files cl:*features*) - (format t "~&Skipping tests based on UMLS distribution~%"))) + (import '(umlisp::*umls-files* umlisp::*umls-cols*))) -(import '(umlisp::*umls-files* umlisp::*umls-cols*)) +(setq *rt-parse* + '( + (deftest :parse/1 + (umlisp::decompose-fil "abc") + "abc" nil) + + (deftest :parse/2 + (umlisp::decompose-fil "dir/abc") + "abc" "dir") + + (deftest :parse/3 + (umlisp::decompose-fil nil) + nil nil) + + (deftest :parse/4 + (umlisp::filename-to-tablename "test") + "test") + + (deftest :parse/5 + (umlisp::filename-to-tablename "TEST.AB.RRF") + "TEST_AB"))) -#+umls-files -(progn +(when (probe-file (umlisp::umls-pathname "MRFILES.RRF")) (umlisp::ensure-ucols+ufiles) - (deftest uparse.1 (length *umls-files*) 52) - (deftest uparse.2 (length *umls-cols*) 327) - (deftest uparse.3 - (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCON"))) - #'string<) - ("CUI" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR" "LAT" "LRL" "LUI" "STR" - "STT" "SUI" "TS")) - (deftest uparse.4 - (sort (umlisp::fields (umlisp::find-ufile "MRCON")) - #'string<) - ("CUI" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR" "LAT" "LRL" "LUI" "STR" - "STT" "SUI" "TS")) - (deftest uparse.5 - (sort - (umlisp::custom-colnames-for-filename "MRCON") - #'string<) - ("KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR")) - (deftest uparse.6 - (compiled-function-p - (umlisp::custom-value-fun - (umlisp::find-ucol "KCUISUI" "MRCON"))) - t) - ) ;; umls-files - -#+umls-files -(setq cl:*features* (delete :umls-files cl:*features*)) - + (setq + *rt-parse* + (append + *rt-parse* + '( + (deftest uparse.1 (length *umls-files*) 64) + (deftest uparse.2 (length *umls-cols*) 327) + (deftest uparse.3 + (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF"))) + #'string<) + ("AUI" "CODE" "CUI" "CVF" "ISPREF" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR" "LAT" "LUI" "SAB" "SAUI" "SCUI" "SDUI" "SRL" "STR" + "STT" "SUI" "SUPPRESS" "TS" "TTY")) + (deftest uparse.4 + (equal + (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF"))) + #'string<) + (sort (umlisp::fields (umlisp::find-ufile "MRCONSO.RRF")) + #'string<)) + t) + (deftest uparse.5 + (sort + (umlisp::custom-colnames-for-filename "MRCONSO.RRF") + #'string<) + ("KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR")) + (deftest uparse.6 + (compiled-function-p + (umlisp::custom-value-fun + (umlisp::find-ucol "KCUISUI" "MRCONSO.RRF"))) + t) + )))) diff --git a/umlisp-tests.asd b/umlisp-tests.asd index 4506451..5d31e3c 100644 --- a/umlisp-tests.asd +++ b/umlisp-tests.asd @@ -18,13 +18,15 @@ :depends-on (:rt :umlisp) :components ((:module tests + :serial t :components ((:file "package") - (:file "basic" :depends-on ("package")) - (:file "parse" :depends-on ("package")))))) + (:file "init") + (:file "basic") + (:file "parse"))))) -(defmethod perform ((o test-op) (c (eql (find-system :umlisp-tests)))) - (or (funcall (intern (symbol-name '#:do-tests) - (find-package '#:regression-test))) +(defmethod perform ((o test-op) (c (eql (find-system 'umlisp-tests)))) + (or (funcall (intern (symbol-name '#:run-tests) + (find-package '#:umlisp-tests))) (error "test-op failed"))) diff --git a/umlisp.asd b/umlisp.asd index 2a4f438..db42aed 100644 --- a/umlisp.asd +++ b/umlisp.asd @@ -10,7 +10,7 @@ ;;;; $Id$ ;;;; ;;;; This file, part of UMLisp, is -;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. +;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. @@ -27,8 +27,8 @@ (:file "utils" :depends-on ("data-structures")) (:file "sql" :depends-on ("utils")) (:file "parse-macros" :depends-on ("sql")) - (:file "parse-2002" :depends-on ("parse-macros")) - (:file "parse-common" :depends-on ("parse-2002")) + (:file "parse-rrf" :depends-on ("parse-macros")) + (:file "parse-common" :depends-on ("parse-rrf")) (:file "create-sql" :depends-on ("parse-common")) (:file "sql-classes" :depends-on ("sql")) (:file "classes" :depends-on ("sql-classes")) @@ -37,6 +37,6 @@ :depends-on (clsql clsql-postgresql-socket kmrcl hyperobject)) #+(or allegro lispworks cmu sbcl openmcl scl) -(defmethod perform ((o test-op) (c (eql (find-system :umlisp)))) - (oos 'load-op 'umlisp-tests) - (oos 'test-op 'umlisp-tests)) +(defmethod perform ((o test-op) (c (eql (find-system 'umlisp)))) + (operate 'load-op 'umlisp-tests) + (operate 'test-op 'umlisp-tests :force t)) diff --git a/utils.lisp b/utils.lisp index 974da72..208a87e 100644 --- a/utils.lisp +++ b/utils.lisp @@ -76,6 +76,15 @@ (nth-value 0 (parse-integer tui)))) tui)) +(defun parse-aui (aui) + (declare (optimize (speed 3) (safety 0))) + (if (stringp aui) + (let ((ch (schar aui 0))) + (if (char-equal ch #\A) + (parse-ui aui) + (nth-value 0 (parse-integer aui)))) + aui)) + (defun parse-eui (eui) (declare (optimize (speed 3) (safety 0))) (if (stringp eui) @@ -86,13 +95,29 @@ eui)) (defconstant +cuisui-scale+ 10000000) -(declaim (type fixnum +cuisui-scale+)) +(declaim (type (integer 0 10000000) +cuisui-scale+)) + +#+64bit +(defun make-cuisui (cui sui) + (declare (fixnum cui sui) + (optimize (speed 3) (safety 0) (space 0))) + (the fixnum + (+ (the fixnum (* +cuisui-scale+ cui)) sui))) +#-64bit (defun make-cuisui (cui sui) (declare (fixnum cui sui) (optimize (speed 3) (safety 0) (space 0))) (+ (* +cuisui-scale+ cui) sui)) +#+64bit +(defun make-cuilui (cui lui) + (declare (fixnum cui lui) + (optimize (speed 3) (safety 0) (space 0))) + (the fixnum + (+ (the fixnum (* +cuisui-scale+ cui)) lui))) + +#-64bit (defun make-cuilui (cui lui) (declare (fixnum cui lui) (optimize (speed 3) (safety 0) (space 0))) @@ -100,6 +125,8 @@ (defun decompose-cuisui (cuisui) "Returns the CUI and SUI of a cuisui number" + #-64bit (declare (integer cuisui)) + #+64bit (declare (fixnum cuisui)) (floor cuisui +cuisui-scale+)) ;;; Lookup functions for uterms,ustr in ucons -- 2.34.1