diff options
| -rw-r--r-- | src/ChangeLog | 8 | ||||
| -rw-r--r-- | src/interp/daase.lisp | 38 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 11 |
3 files changed, 36 insertions, 21 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 6110e775..d3b2c344 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,13 @@ 2011-09-04 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/lisplib.boot (writeAbbreviation): New. + (writePredicates): Likewise. + (finalizeLisplib): Use them. + * interp/daase.lisp (squeezeCopy): New, + Use it in place of SQUEEZE. + +2011-09-04 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/lisplib.boot: Likewise. * interp/define.boot: Remove $lisplibAncestors. diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp index 1a713b05..b3cb6a64 100644 --- a/src/interp/daase.lisp +++ b/src/interp/daase.lisp @@ -934,7 +934,6 @@ (cond ((eq key 'superdomain) (rplaca data (unsqueeze (car data)))) (t (setq data (unsqueeze data)))) - ;;(setq data (unsqueeze (read stream))) (case key ; cache the result of the database read (operation (setf (gethash constructor *operation-hash*) data)) @@ -1152,6 +1151,13 @@ (apply key args))) (|sayKeyedMsg| 'S2IU0001 (list key object)))))) +;; The infamous SQUEEZE functions couple produces its results by +;; in-place transmoglification. We use this function in places +;; where we want the arguments to remain unmolested. +;; -- gdr, 2011-09-03 +(defun |squeezeCopy| (x) + (squeeze (copy-tree x))) + ; making new databases consists of: ; 1) reset all of the system hash tables ; *) set up Union, Record and Mapping @@ -1240,13 +1246,7 @@ (when (setq dbstruct (|constructorDB| con)) (setf (|dbDualSignature| dbstruct) (cons nil (mapcar #'|categoryForm?| - ;; The DBs have been munged by SQUEEZE - ;; in WRITE-BROWSEDB, WRITE-OPERATIONDB - ;; WRITE-CATEGORYDB. Unsqueeze a copy - ;; of them before checking for category - ;; form-ness. This is sick! FIXME. - (unsqueeze (copy-tree - (cddar (|dbConstructorModemap| dbstruct))))))) + (cddar (|dbConstructorModemap| dbstruct))))) (when (and (eq (|dbConstructorKind| dbstruct) '|category|) (= (length (setq d (|domainsOf| (list con) NIL NIL))) 1)) (setq d (caar d)) @@ -1342,13 +1342,13 @@ (let (struct) (setq struct (|constructorDB| constructor)) (setq opalistpos (file-position out)) - (print (squeeze (|dbOperations| struct)) out) + (print (|squeezeCopy| (|dbOperations| struct)) out) (finish-output out) (setq cmodemappos (file-position out)) - (print (squeeze (|dbConstructorModemap| struct)) out) + (print (|squeezeCopy| (|dbConstructorModemap| struct)) out) (finish-output out) (setq modemapspos (file-position out)) - (print (squeeze (|dbModemaps| struct)) out) + (print (|squeezeCopy| (|dbModemaps| struct)) out) (finish-output out) (let ((entry (|dbModule| struct))) (cond ((consp entry) @@ -1358,7 +1358,7 @@ (setq obj (pathname-name (first (last (pathname-directory entry)))))) (t (setq obj nil)))) - (setq concategory (squeeze (|dbCategory| struct))) + (setq concategory (|squeezeCopy| (|dbCategory| struct))) (if concategory ; if category then write data else write nil (progn (setq categorypos (file-position out)) @@ -1369,7 +1369,7 @@ (setq cosig (|dbDualSignature| struct)) (setq kind (|dbConstructorKind| struct)) (setq defaultdomain (|dbDefaultDomain| struct)) - (setq ancestors (squeeze (gethash constructor *ancestors-hash*))) ;cattable.boot + (setq ancestors (|squeezeCopy| (gethash constructor *ancestors-hash*))) ;cattable.boot (if ancestors (progn (setq ancestorspos (file-position out)) @@ -1382,7 +1382,7 @@ (let ((super (|dbSuperDomain| struct))) (when super (prog1 (file-position out) - (print (list (squeeze (car super)) (second super)) out) + (print (list (|squeezeCopy| (car super)) (second super)) out) (finish-output out))))) (push (list constructor opalistpos cmodemappos modemapspos @@ -1410,16 +1410,16 @@ ; sourcefile is small. store the string directly (setq src (database-sourcefile struct)) (setq formpos (file-position out)) - (print (squeeze (|dbConstructorForm| struct)) out) + (print (|squeezeCopy| (|dbConstructorForm| struct)) out) (finish-output out) (setq docpos (file-position out)) (print (database-documentation struct) out) (finish-output out) (setq attpos (file-position out)) - (print (squeeze (|dbAttributes| struct)) out) + (print (|squeezeCopy| (|dbAttributes| struct)) out) (finish-output out) (setq predpos (file-position out)) - (print (squeeze (|dbPredicates| struct)) out) + (print (|squeezeCopy| (|dbPredicates| struct)) out) (finish-output out) (push (list constructor src formpos docpos attpos predpos) master))) (finish-output out) @@ -1444,7 +1444,7 @@ (setq pos value) (progn (setq pos (file-position out)) - (print (squeeze value) out) + (print (|squeezeCopy| value) out) (finish-output out))) (push (list key pos) master)) *hasCategory-hash*) @@ -1494,7 +1494,7 @@ (finish-output out) (maphash #'(lambda (key value) (setq pos (file-position out)) - (print (squeeze value) out) + (print (|squeezeCopy| value) out) (finish-output out) (push (cons key pos) master)) *operation-hash*) diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 898b46cf..8c39a1b5 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -543,12 +543,19 @@ writeInfo(ctor,info,key,prop,file) == writeKind(ctor,kind,file) == writeInfo(ctor,kind,'constructorKind,'dbConstructorKind,file) +writeAbbreviation(db,file) == + writeInfo(dbConstructor db,dbAbbreviation db, + 'abbreviation,'dbAbbreviation,file) + writeConstructorForm(ctor,form,file) == writeInfo(ctor,form,'constructorForm,'dbConstructorForm,file) writeSuperDomain(ctor,domPred,file) == writeInfo(ctor,domPred,'superDomain,'dbSuperDomain,file) +writePredicates(ctor,preds,file) == + writeInfo(ctor,preds,'predicates,'dbPredicates,file) + writeOperations(ctor,ops,file) == writeInfo(ctor,ops,'operationAlist,'dbOperations,file) @@ -598,8 +605,8 @@ finalizeLisplib(ctor,libName) == removeZeroOne mergeSignatureAndLocalVarAlists($lisplibSignatureAlist, $lisplibVariableAlist),$libFile) writeAttributes(ctor,removeZeroOne dbAttributes db,$libFile) - lisplibWrite('"predicates",removeZeroOne $lisplibPredicates,$libFile) - lisplibWrite('"abbreviation",dbAbbreviation db,$libFile) + writePredicates(ctor,removeZeroOne $lisplibPredicates,$libFile) + writeAbbreviation(db,$libFile) writePrincipals(ctor,removeZeroOne dbPrincipals db,$libFile) writeAncestors(ctor,removeZeroOne dbAncestors db,$libFile) lisplibWrite('"documentation",finalizeDocumentation ctor,$libFile) |