diff options
Diffstat (limited to 'src/interp/daase.lisp')
| -rw-r--r-- | src/interp/daase.lisp | 1762 |
1 files changed, 1762 insertions, 0 deletions
diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp new file mode 100644 index 00000000..3d6b715c --- /dev/null +++ b/src/interp/daase.lisp @@ -0,0 +1,1762 @@ +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; Copyright (C) 2007, Gabriel Dos Reis. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +;; In order to understand this program you need to understand some details +;; of the structure of the databases it reads. Axiom has 5 databases, +;; the interp.daase, operation.daase, category.daase, compress.daase, and +;; browse.daase. The compress.daase is special and does not follow the +;; normal database format. +;; +;; This documentation refers to KAF files which are random access files. +;; NRLIB files are KAF files (look for NRLIB/index.KAF) +;; The format of a random access file is +;; \begin{verbatim} +;; byte-offset-of-key-table +;; first-entry +;; second-entry +;; ... +;; last-entry +;; ((key1 . first-entry-byte-address) +;; (key2 . second-entry-byte-address) +;; ... +;; (keyN . last-entry-byte-address)) +;; \end{verbatim} +;; The key table is a standard lisp alist. +;; +;; To open a database you fetch the first number, seek to that location, +;; and (read) which returns the key-data alist. To look up data you +;; index into the key-data alist, find the ith-entry-byte-address, +;; seek to that address, and (read). +;; +;; For instance, see src/share/algebra/USERS.DAASE/index.KAF +;; +;; One existing optimization is that if the data is a simple thing like a +;; symbol then the nth-entry-byte-address is replaced by immediate data. +;; +;; Another existing one is a compression algorithm applied to the +;; data so that the very long names don't take up so much space. +;; We could probably remove the compression algorithm as 64k is no +;; longer considered 'huge'. The database-abbreviation routine +;; handles this on read and write-compress handles this on write. +;; The squeeze routine is used to compress the keys, the unsqueeze +;; routine uncompresses them. Making these two routines disappear +;; should remove all of the compression. +;; +;; Indeed, a faster optimization is to simply read the whole database +;; into the image before it is saved. The system would be easier to +;; understand and the interpreter would be faster. +;; +;; The system uses another optimization: database contains a stamp +;; (consisting of offset to the main list and build time). Before +;; saving the image selected data is fetched to memory. When the +;; saved image starts it checks if the stamp of saved data matches +;; in-core data -- in case of agreement in-core data is used. +;; Parts of the datatabase which was not pre-loaded is still +;; (lazily) fetched from the filesystem. +;; +;; Database files are very similar to KAF files except that there +;; is an optimization (currently broken) which makes the first +;; item a pair of two numbers. The first number in the pair is +;; the offset of the key-value table, the second is a time stamp. +;; If the time stamp in the database matches the time stamp in +;; the image the database is not needed (since the internal hash +;; tables already contain all of the information). When the database +;; is built the time stamp is saved in both the gcl image and the +;; database. + + +;;TTT 7/2/97 +; Regarding the 'ancestors field for a category: At database build +; time there exists a *ancestors-hash* hash table that gets filled +; with CATEGORY (not domain) ancestor information. This later provides +; the information that goes into interp.daase This *ancestors-hash* +; does not exist at normal runtime (it can be made by a call to +; genCategoryTable). Note that the ancestor information in +; *ancestors-hash* (and hence interp.daase) involves #1, #2, etc +; instead of R, Coef, etc. The latter thingies appear in all +; .NRLIB/index.KAF files. So we need to be careful when we )lib +; categories and update the ancestor info. + + +; This file contains the code to build, open and access the .DAASE +; files this file contains the code to )library NRLIBS and asy files + +; There is a major issue about the data that resides in these +; databases. the fundamental problem is that the system requires more +; information to build the databases than it needs to run the +; interpreter. in particular, MODEMAP.DAASE is constructed using +; properties like "modemaps" but the interpreter will never ask for +; this information. + +; So, the design is as follows: +; first, the MODEMAP.DAASE needs to be built. this is done by doing +; a )library on ALL of the NRLIB files that are going into the system. +; this will bring in "modemap" information and add it to the +; *modemaps-hash* hashtable. +; next, database build proceeds, accessing the "modemap" property +; from the hashtables. once this completes this information is never +; used again. +; next, the interp.daase database is built. this contains only the +; information necessary to run the interpreter. note that during the +; running of the interpreter users can extend the system by do a +; )library on a new NRLIB file. this will cause fields such as "modemap" +; to be read and hashed. + +; In the old system each constructor (e.g. LIST) had one library directory +; (e.g. LIST.NRLIB). this directory contained a random access file called +; the index.KAF file. the interpreter needed this KAF file at runtime for +; two entries, the operationAlist and the ConstructorModemap. +; during the redesign for the new compiler we decided to merge all of +; these .NRLIB/index.KAF files into one database, INTERP.DAASE. +; requests to get information from this database are intended to be +; cached so that multiple references do not cause additional disk i/o. +; this database is left open at all times as it is used frequently by +; the interpreter. one minor complication is that newly compiled files +; need to override information that exists in this database. +; The design calls for constructing a random read (KAF format) file +; that is accessed by functions that cache their results. when the +; database is opened the list of constructor-index pairs is hashed +; by constructor name. a request for information about a constructor +; causes the information to replace the index in the hash table. since +; the index is a number and the data is a non-numeric sexpr there is +; no source of confusion about when the data needs to be read. +; +; The format of this new database is as follows: +; +;first entry: +; an integer giving the byte offset to the constructor alist +; at the bottom of the file +;second and subsequent entries (one per constructor) +; (operationAlist) +; (constructorModemap) +; .... +;last entry: (pointed at by the first entry) +; an alist of (constructor . index) e.g. +; ( (PI offset-of-operationAlist offset-of-constructorModemap) +; (NNI offset-of-operationAlist offset-of-constructorModemap) +; ....) +; This list is read at open time and hashed by the car of each item. + +; the system has been changed to use the property list of the +; symbols rather than hash tables. since we already hashed once +; to get the symbol we need only an offset to get the property +; list. this also has the advantage that eq hash tables no longer +; need to be moved during garbage collection. +; there are 3 potential speedups that could be done. the best +; would be to use the value cell of the symbol rather than the +; property list but i'm unable to determine all uses of the +; value cell at the present time. +; a second speedup is to guarantee that the property list is +; a single item, namely the database structure. this removes +; an assoc but leaves one open to breaking the system if someone +; adds something to the property list. this was not done because +; of the danger mentioned. +; a third speedup is to make the getdatabase call go away, either +; by making it a macro or eliding it entirely. this was not done +; because we want to keep the flexibility of changing the database +; forms. + +; the new design does not use hash tables. the database structure +; contains an entry for each item that used to be in a hash table. +; initially the structure contains file-position pointers and +; these are replaced by real data when they are first looked up. +; the database structure is kept on the property list of the +; constructor, thus, (get '|DenavitHartenbergMatrix| 'database) +; will return the database structure object. + +; each operation has a property on its symbol name called 'operation +; which is a list of all of the signatures of operations with that name. + +; -- tim daly + +(in-package "BOOT") + +(defstruct database + abbreviation ; interp. + ancestors ; interp. + constructor ; interp. + constructorcategory ; interp. + constructorkind ; interp. + constructormodemap ; interp. + cosig ; interp. + defaultdomain ; interp. + modemaps ; interp. + niladic ; interp. + object ; interp. + operationalist ; interp. + documentation ; browse. + constructorform ; browse. + attributes ; browse. + predicates ; browse. + sourcefile ; browse. + parents ; browse. + users ; browse. + dependents ; browse. + spare ; superstition + ) ; database structure + +; there are only a small number of domains that have default domains. +; rather than keep this slot in every domain we maintain a list here. + +(defvar *defaultdomain-list* '( + (|MultisetAggregate| |Multiset|) + (|FunctionSpace| |Expression|) + (|AlgebraicallyClosedFunctionSpace| |Expression|) + (|ThreeSpaceCategory| |ThreeSpace|) + (|DequeueAggregate| |Dequeue|) + (|ComplexCategory| |Complex|) + (|LazyStreamAggregate| |Stream|) + (|AssociationListAggregate| |AssociationList|) + (|QuaternionCategory| |Quaternion|) + (|PriorityQueueAggregate| |Heap|) + (|PointCategory| |Point|) + (|PlottableSpaceCurveCategory| |Plot3D|) + (|PermutationCategory| |Permutation|) + (|StringCategory| |String|) + (|FileNameCategory| |FileName|) + (|OctonionCategory| |Octonion|))) + +; this hash table is used to answer the question "does domain x +; have category y?". this is answered by constructing a pair of +; (x . y) and doing an equal hash into this table. + +(defvar *operation-hash* nil "given an operation name, what are its modemaps?") +(defvar *hasCategory-hash* nil "answers x has y category questions") + +(defvar *miss* nil "print out cache misses on getdatabase calls") + + ; note that constructorcategory information need only be kept for + ; items of type category. this will be fixed in the next iteration + ; when the need for the various caches are reviewed + + ; note that the *modemaps-hash* information does not need to be kept + ; for system files. these are precomputed and kept in modemap.daase + ; however, for user-defined files these are needed. + ; currently these are added to the database for 2 reasons: + ; there is a still-unresolved issue of user database extensions + ; this information is used during database build time + + + +; this are the streams for the databases. they are always open. +; there is an optimization for speeding up system startup. if the +; database is opened and the ..-stream-stamp* variable matches the +; position information in the database then the database is NOT +; read in and is assumed to match the in-core version + +(defvar *compressvector* nil "a vector of things to compress in the databases") +(defvar *compressVectorLength* 0 "length of the compress vector") +(defvar *compress-stream* nil "an stream containing the compress vector") +(defvar *compress-stream-stamp* 0 "*compress-stream* (position . time)") + +(defvar *interp-stream* nil "an open stream to the interpreter database") +(defvar *interp-stream-stamp* 0 "*interp-stream* (position . time)") + +; this is indexed by operation, not constructor +(defvar *operation-stream* nil "the stream to operation.daase") +(defvar *operation-stream-stamp* 0 "*operation-stream* (position . time)") + +(defvar *browse-stream* nil "an open stream to the browser database") +(defvar *browse-stream-stamp* 0 "*browse-stream* (position . time)") + +; this is indexed by (domain . category) +(defvar *category-stream* nil "an open stream to the category table") +(defvar *category-stream-stamp* 0 "*category-stream* (position . time)") + +(defvar *allconstructors* nil "a list of all the constructors in the system") +(defvar *allOperations* nil "a list of all the operations in the system") + +(defvar *asharpflags* "-O -laxiom -Fasy -Flsp" "library compiler flags") + +(defun asharp (file &optional (flags *asharpflags*)) + "call the asharp compiler" + (system::system + (concatenate 'string (|systemRootDirectory|) "/compiler/bin/axiomxl " + flags " " file))) + +(defun resethashtables () + "set all -hash* to clean values. used to clean up core before saving system" + (setq *hascategory-hash* (make-hash-table :test #'equal)) + (setq *operation-hash* (make-hash-table)) + (setq *allconstructors* nil) + (setq *compressvector* nil) + (setq *compress-stream-stamp* '(0 . 0)) + (compressopen) + (setq *interp-stream-stamp* '(0 . 0)) + (interpopen) + (setq *operation-stream-stamp* '(0 . 0)) + (operationopen) + (setq *browse-stream-stamp* '(0 . 0)) + (browseopen) + (setq *category-stream-stamp* '(0 . 0)) + (categoryopen) ;note: this depends on constructorform in browse.daase +#-:CCL (initial-getdatabase) + (close *interp-stream*) + (close *operation-stream*) + (close *category-stream*) + (close *browse-stream*) +#+:AKCL (gbc t) +) + +(defun initial-getdatabase () + "fetch data we want in the saved system" + (let (hascategory constructormodemapAndoperationalist operation constr) + (format t "Initial getdatabase~%") + (setq hascategory '( + (|Equation| . |Ring|) + (|Expression| . |CoercibleTo|) (|Expression| . |CommutativeRing|) + (|Expression| . |IntegralDomain|) (|Expression| . |Ring|) + (|Float| . |RetractableTo|) + (|Fraction| . |Algebra|) (|Fraction| . |CoercibleTo|) + (|Fraction| . |OrderedSet|) (|Fraction| . |RetractableTo|) + (|Integer| . |Algebra|) (|Integer| . |CoercibleTo|) + (|Integer| . |ConvertibleTo|) (|Integer| . |LinearlyExplicitRingOver|) + (|Integer| . |RetractableTo|) + (|List| . |CoercibleTo|) (|List| . |FiniteLinearAggregate|) + (|List| . |OrderedSet|) + (|Polynomial| . |CoercibleTo|) (|Polynomial| . |CommutativeRing|) + (|Polynomial| . |ConvertibleTo|) (|Polynomial| . |OrderedSet|) + (|Polynomial| . |RetractableTo|) + (|Symbol| . |CoercibleTo|) (|Symbol| . |ConvertibleTo|) + (|Variable| . |CoercibleTo|))) + (dolist (pair hascategory) (getdatabase pair 'hascategory)) + (setq constructormodemapAndoperationalist '( + |BasicOperator| |Boolean| + |CardinalNumber| |Color| |Complex| + |Database| + |Equation| |EquationFunctions2| |Expression| + |Float| |Fraction| |FractionFunctions2| + |Integer| |IntegralDomain| + |Kernel| + |List| + |Matrix| |MappingPackage1| + |Operator| |OutputForm| + |NonNegativeInteger| + |ParametricPlaneCurve| |ParametricSpaceCurve| |Point| |Polynomial| + |PolynomialFunctions2| |PositiveInteger| + |Ring| + |SetCategory| |SegmentBinding| |SegmentBindingFunctions2| |DoubleFloat| + |SparseMultivariatePolynomial| |SparseUnivariatePolynomial| |Segment| + |String| |Symbol| + |UniversalSegment| + |Variable| |Vector|)) + (dolist (con constructormodemapAndoperationalist) + (getdatabase con 'constructormodemap) + (getdatabase con 'operationalist)) + (setq operation '( + |+| |-| |*| |/| |**| |coerce| |convert| |elt| |equation| + |float| |sin| |cos| |map| |SEGMENT|)) + (dolist (op operation) (getdatabase op 'operation)) + (setq constr '( ;these are sorted least-to-most freq. delete early ones first + |Factored| |SparseUnivariatePolynomialFunctions2| |TableAggregate&| + |RetractableTo&| |RecursiveAggregate&| |UserDefinedPartialOrdering| + |None| |UnivariatePolynomialCategoryFunctions2| |IntegerPrimesPackage| + |SetCategory&| |IndexedExponents| |QuotientFieldCategory&| |Polynomial| + |EltableAggregate&| |PartialDifferentialRing&| |Set| + |UnivariatePolynomialCategory&| |FlexibleArray| + |SparseMultivariatePolynomial| |PolynomialCategory&| + |DifferentialExtension&| |IndexedFlexibleArray| |AbelianMonoidRing&| + |FiniteAbelianMonoidRing&| |DivisionRing&| |FullyLinearlyExplicitRingOver&| + |IndexedVector| |IndexedOneDimensionalArray| |LocalAlgebra| |Localize| + |Boolean| |Field&| |Vector| |IndexedDirectProductObject| |Aggregate&| + |PolynomialRing| |FreeModule| |IndexedDirectProductAbelianGroup| + |IndexedDirectProductAbelianMonoid| |SingletonAsOrderedSet| + |SparseUnivariatePolynomial| |Fraction| |Collection&| |HomogeneousAggregate&| + |RepeatedSquaring| |IntegerNumberSystem&| |AbelianSemiGroup&| + |AssociationList| |OrderedRing&| |SemiGroup&| |Symbol| + |UniqueFactorizationDomain&| |EuclideanDomain&| |IndexedAggregate&| + |GcdDomain&| |IntegralDomain&| |DifferentialRing&| |Monoid&| |Reference| + |UnaryRecursiveAggregate&| |OrderedSet&| |AbelianGroup&| |Algebra&| + |Module&| |Ring&| |StringAggregate&| |AbelianMonoid&| + |ExtensibleLinearAggregate&| |PositiveInteger| |StreamAggregate&| + |IndexedString| |IndexedList| |ListAggregate&| |LinearAggregate&| + |Character| |String| |NonNegativeInteger| |SingleInteger| + |OneDimensionalArrayAggregate&| |FiniteLinearAggregate&| |PrimitiveArray| + |Integer| |List| |OutputForm|)) + (dolist (con constr) + (let ((c (concatenate 'string + (|systemRootDirectory|) "/algebra/" + (string (getdatabase con 'abbreviation)) ".o"))) + (format t " preloading ~a.." c) + (if (probe-file c) + (progn + (put con 'loaded c) + (load c) + (format t "loaded.~%")) + (format t "skipped.~%")))) + (format t "~%"))) + +; format of an entry in interp.daase: +; (constructor-name +; operationalist +; constructormodemap +; modemaps -- this should not be needed. eliminate it. +; object -- the name of the object file to load for this con. +; constructorcategory -- note that this info is the cadar of the +; constructormodemap for domains and packages so it is stored +; as NIL for them. it is valid for categories. +; niladic -- t or nil directly +; unused +; cosig -- kept directly +; constructorkind -- kept directly +; defaultdomain -- a short list, for %i +; ancestors -- used to compute new category updates +; ) +(defun interpOpen () + "open the interpreter database and hash the keys" + (let (constructors pos stamp dbstruct) + (setq *interp-stream* (open (DaaseName "interp.daase" nil))) + (setq stamp (read *interp-stream*)) + (unless (equal stamp *interp-stream-stamp*) + (format t " Re-reading interp.daase") + (setq *interp-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *interp-stream* pos) + (setq constructors (read *interp-stream*)) + (dolist (item constructors) + (setq item (unsqueeze item)) + (setq *allconstructors* (adjoin (first item) *allconstructors*)) + (setq dbstruct (make-database)) + (setf (get (car item) 'database) dbstruct) + (setf (database-operationalist dbstruct) (second item)) + (setf (database-constructormodemap dbstruct) (third item)) + (setf (database-modemaps dbstruct) (fourth item)) + (setf (database-object dbstruct) (fifth item)) + (setf (database-constructorcategory dbstruct) (sixth item)) + (setf (database-niladic dbstruct) (seventh item)) + (setf (database-abbreviation dbstruct) (eighth item)) + (setf (get (eighth item) 'abbreviationfor) (first item)) ;invert + (setf (database-cosig dbstruct) (ninth item)) + (setf (database-constructorkind dbstruct) (tenth item)) + (setf (database-ancestors dbstruct) (nth 11 item)))) + (format t "~&"))) + +; this is an initialization function for the constructor database +; it sets up 2 hash tables, opens the database and hashes the index values + +; there is a slight asymmetry in this code. sourcefile information for +; system files is only the filename and extension. for user files it +; contains the full pathname. when the database is first opened the +; sourcefile slot contains system names. the lookup function +; has to prefix the $spadroot information if the directory-namestring is +; null (we don't know the real root at database build time). +; a object-hash table is set up to look up nrlib and ao information. +; this slot is empty until a user does a )library call. we remember +; the location of the nrlib or ao file for the users local library +; at that time. a NIL result from this probe means that the +; library is in the system-specified place. when we get into multiple +; library locations this will also contain system files. + + +; format of an entry in browse.daase: +; ( constructorname +; sourcefile +; constructorform +; documentation +; attributes +; predicates +; ) + +(defun browseOpen () + "open the constructor database and hash the keys" + (let (constructors pos stamp dbstruct) + (setq *browse-stream* (open (DaaseName "browse.daase" nil))) + (setq stamp (read *browse-stream*)) + (unless (equal stamp *browse-stream-stamp*) + (format t " Re-reading browse.daase") + (setq *browse-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *browse-stream* pos) + (setq constructors (read *browse-stream*)) + (dolist (item constructors) + (setq item (unsqueeze item)) + (unless (setq dbstruct (get (car item) 'database)) + (format t "browseOpen:~%") + (format t "the browse database contains a contructor ~a~%" item) + (format t "that is not in the interp.daase file. we cannot~%") + (format t "get the database structure for this constructor and~%") + (warn "will create a new one~%") + (setf (get (car item) 'database) (setq dbstruct (make-database))) + (setq *allconstructors* (adjoin item *allconstructors*))) + (setf (database-sourcefile dbstruct) (second item)) + (setf (database-constructorform dbstruct) (third item)) + (setf (database-documentation dbstruct) (fourth item)) + (setf (database-attributes dbstruct) (fifth item)) + (setf (database-predicates dbstruct) (sixth item)) + (setf (database-parents dbstruct) (seventh item)))) + (format t "~&"))) + +(defun categoryOpen () + "open category.daase and hash the keys" + (let (pos keys stamp) + (setq *category-stream* (open (DaaseName "category.daase" nil))) + (setq stamp (read *category-stream*)) + (unless (equal stamp *category-stream-stamp*) + (format t " Re-reading category.daase") + (setq *category-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *category-stream* pos) + (setq keys (read *category-stream*)) + (setq *hasCategory-hash* (make-hash-table :test #'equal)) + (dolist (item keys) + (setq item (unsqueeze item)) + (setf (gethash (first item) *hasCategory-hash*) (second item)))) + (format t "~&"))) + +(defun operationOpen () + "read operation database and hash the keys" + (let (operations pos stamp) + (setq *operation-stream* (open (DaaseName "operation.daase" nil))) + (setq stamp (read *operation-stream*)) + (unless (equal stamp *operation-stream-stamp*) + (format t " Re-reading operation.daase") + (setq *operation-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *operation-stream* pos) + (setq operations (read *operation-stream*)) + (dolist (item operations) + (setq item (unsqueeze item)) + (setf (gethash (car item) *operation-hash*) (cdr item)))) + (format t "~&"))) + +(defun addoperations (constructor oldmaps) + "add ops from a )library domain to *operation-hash*" + (declare (special *operation-hash*)) + (dolist (map oldmaps) ; out with the old + (let (oldop op) + (setq op (car map)) + (setq oldop (getdatabase op 'operation)) + (setq oldop (lisp::delete (cdr map) oldop :test #'equal)) + (setf (gethash op *operation-hash*) oldop))) + (dolist (map (getdatabase constructor 'modemaps)) ; in with the new + (let (op newmap) + (setq op (car map)) + (setq newmap (getdatabase op 'operation)) + (setf (gethash op *operation-hash*) (cons (cdr map) newmap))))) + +(defun showdatabase (constructor) + (format t "~&~a: ~a~%" 'constructorkind + (getdatabase constructor 'constructorkind)) + (format t "~a: ~a~%" 'cosig + (getdatabase constructor 'cosig)) + (format t "~a: ~a~%" 'operation + (getdatabase constructor 'operation)) + (format t "~a: ~%" 'constructormodemap) + (pprint (getdatabase constructor 'constructormodemap)) + (format t "~&~a: ~%" 'constructorcategory) + (pprint (getdatabase constructor 'constructorcategory)) + (format t "~&~a: ~%" 'operationalist) + (pprint (getdatabase constructor 'operationalist)) + (format t "~&~a: ~%" 'modemaps) + (pprint (getdatabase constructor 'modemaps)) + (format t "~a: ~a~%" 'hascategory + (getdatabase constructor 'hascategory)) + (format t "~a: ~a~%" 'object + (getdatabase constructor 'object)) + (format t "~a: ~a~%" 'niladic + (getdatabase constructor 'niladic)) + (format t "~a: ~a~%" 'abbreviation + (getdatabase constructor 'abbreviation)) + (format t "~a: ~a~%" 'constructor? + (getdatabase constructor 'constructor?)) + (format t "~a: ~a~%" 'constructor + (getdatabase constructor 'constructor)) + (format t "~a: ~a~%" 'defaultdomain + (getdatabase constructor 'defaultdomain)) + (format t "~a: ~a~%" 'ancestors + (getdatabase constructor 'ancestors)) + (format t "~a: ~a~%" 'sourcefile + (getdatabase constructor 'sourcefile)) + (format t "~a: ~a~%" 'constructorform + (getdatabase constructor 'constructorform)) + (format t "~a: ~a~%" 'constructorargs + (getdatabase constructor 'constructorargs)) + (format t "~a: ~a~%" 'attributes + (getdatabase constructor 'attributes)) + (format t "~a: ~%" 'predicates) + (pprint (getdatabase constructor 'predicates)) + (format t "~a: ~a~%" 'documentation + (getdatabase constructor 'documentation)) + (format t "~a: ~a~%" 'parents + (getdatabase constructor 'parents))) + +(defun setdatabase (constructor key value) + (let (struct) + (when (symbolp constructor) + (unless (setq struct (get constructor 'database)) + (setq struct (make-database)) + (setf (get constructor 'database) struct)) + (case key + (abbreviation + (setf (database-abbreviation struct) value) + (when (symbolp value) + (setf (get value 'abbreviationfor) constructor))) + (constructorkind + (setf (database-constructorkind struct) value)))))) + +(defun deldatabase (constructor key) + (when (symbolp constructor) + (case key + (abbreviation + (setf (get constructor 'abbreviationfor) nil))))) + +(defun getdatabase (constructor key) + (declare (special *miss*)) + (when (eq *miss* t) (format t "getdatabase call: ~20a ~a~%" constructor key)) + (let (data table stream ignore struct) + (declare (ignore ignore)) + (when (or (symbolp constructor) + (and (eq key 'hascategory) (pairp constructor))) + (case key +; note that abbreviation, constructorkind and cosig are heavy hitters +; thus they occur first in the list of things to check + (abbreviation + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-abbreviation struct)))) + (constructorkind + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructorkind struct)))) + (cosig + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-cosig struct)))) + (operation + (setq stream *operation-stream*) + (setq data (gethash constructor *operation-hash*))) + (constructormodemap + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructormodemap struct)))) + (constructorcategory + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructorcategory struct)) + (when (null data) ;domain or package then subfield of constructormodemap + (setq data (cadar (getdatabase constructor 'constructormodemap)))))) + (operationalist + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-operationalist struct)))) + (modemaps + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-modemaps struct)))) + (hascategory + (setq table *hasCategory-hash*) + (setq stream *category-stream*) + (setq data (gethash constructor table))) + (object + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-object struct)))) + (asharp? + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-object struct)))) + (niladic + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-niladic struct)))) + (constructor? + (when (setq struct (get constructor 'database)) + (setq data (when (database-operationalist struct) t)))) + (superdomain ; only 2 superdomains in the world + (case constructor + (|NonNegativeInteger| + (setq data '((|Integer|) (IF (< |#1| 0) |false| |true|)))) + (|PositiveInteger| + (setq data '((|NonNegativeInteger|) (< 0 |#1|)))))) + (constructor + (when (setq data (get constructor 'abbreviationfor)))) + (defaultdomain + (setq data (cadr (assoc constructor *defaultdomain-list*)))) + (ancestors + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-ancestors struct)))) + (sourcefile + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-sourcefile struct)))) + (constructorform + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructorform struct)))) + (constructorargs + (setq data (cdr (getdatabase constructor 'constructorform)))) + (attributes + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-attributes struct)))) + (predicates + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-predicates struct)))) + (documentation + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-documentation struct)))) + (parents + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-parents struct)))) + (users + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-users struct)))) + (dependents + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-dependents struct)))) + (otherwise (warn "~%(GETDATABASE ~a ~a) failed~%" constructor key))) + (when (numberp data) ;fetch the real data + (when *miss* (format t "getdatabase miss: ~20a ~a~%" key constructor)) + (file-position stream data) + (setq data (unsqueeze (read stream))) + (case key ; cache the result of the database read + (operation (setf (gethash constructor *operation-hash*) data)) + (hascategory (setf (gethash constructor *hascategory-hash*) data)) + (constructorkind (setf (database-constructorkind struct) data)) + (cosig (setf (database-cosig struct) data)) + (constructormodemap (setf (database-constructormodemap struct) data)) + (constructorcategory (setf (database-constructorcategory struct) data)) + (operationalist (setf (database-operationalist struct) data)) + (modemaps (setf (database-modemaps struct) data)) + (object (setf (database-object struct) data)) + (niladic (setf (database-niladic struct) data)) + (abbreviation (setf (database-abbreviation struct) data)) + (constructor (setf (database-constructor struct) data)) + (ancestors (setf (database-ancestors struct) data)) + (constructorform (setf (database-constructorform struct) data)) + (attributes (setf (database-attributes struct) data)) + (predicates (setf (database-predicates struct) data)) + (documentation (setf (database-documentation struct) data)) + (parents (setf (database-parents struct) data)) + (users (setf (database-users struct) data)) + (dependents (setf (database-dependents struct) data)) + (sourcefile (setf (database-sourcefile struct) data)))) + (case key ; fixup the special cases + (sourcefile + (when (and data (string= (directory-namestring data) "") + (string= (pathname-type data) "spad")) + (setq data + (concatenate 'string (|systemRootDirectory|) "/../../src/algebra/" data)))) + (asharp? ; is this asharp code? + (if (consp data) + (setq data (cdr data)) + (setq data nil))) + (object ; fix up system object pathname + (if (consp data) + (setq data + (if (string= (directory-namestring (car data)) "") + (concatenate 'string (|systemRootDirectory|) "/algebra/" (car data) ".o") + (car data))) + (when (and data (string= (directory-namestring data) "")) + (setq data (concatenate 'string (|systemRootDirectory|) "/algebra/" data ".o"))))))) + data)) + +; )library top level command -- soon to be obsolete + +(defun |with| (args) + (|library| args)) + +;; Current directory +;; Contributed by Juergen Weiss. +#+:cmu +(defun get-current-directory () + (namestring (extensions::default-directory))) + +#+(or :akcl :gcl) +(defun get-current-directory () + (namestring (truename ""))) + + +; )library top level command + +(defun |library| (args) + (declare (special |$options|)) + (declare (special |$newConlist|)) + (setq original-directory (get-current-directory)) + (setq |$newConlist| nil) + (localdatabase args |$options|) +#+:CCL + (dolist (a args) (check-module-exists a)) + (|extendLocalLibdb| |$newConlist|) + (system::chdir original-directory) + (tersyscommand)) + +;; check-module-exists looks to see if a module exists in one of the current +;; libraries and, if not, compiles it. If the output-library exists but has not +;; been opened then it opens it first. +#+:CCL +(defun check-module-exists (module) + (prog (|$options| mdate) + (if (and (not output-library) (filep (or |$outputLibraryName| "user.lib"))) + (seq (setq |$outputLibraryName| + (if |$outputLibraryName| (truename |$outputLibraryName|) + (make-pathname :directory (get-current-directory) + :name "user.lib"))) + (|openOutputLibrary| |$outputLibraryName|))) + (setq mdate (modulep module)) + (setq |$options| '((|nolibrary| nil) (|quiet| nil))) + (|sayMSG| (format nil " Checking for module ~s." (namestring module))) + (let* ((fn (concatenate 'string (namestring module) ".lsp")) + (fdate (filedate fn)) ) + (if (and fdate (or (null mdate) (datelessp mdate fdate))) + (|compileAsharpLispCmd| (list fn)) + (let* ((fn (concatenate 'string (namestring module) ".NRLIB")) + (fdate (filedate fn)) ) + (if (and fdate (or (null mdate) (datelessp mdate fdate))) + (|compileSpadLispCmd| (list fn)))))))) + +; localdatabase tries to find files in the order of: +; NRLIB/index.KAF +; .asy +; .ao, then asharp to .asy + +(defun localdatabase (filelist options &optional (make-database? nil)) + "read a local filename and update the hash tables" + (labels ( + (processOptions (options) + (let (only dir noexpose) + (when (setq only (assoc '|only| options)) + (setq options (lisp::delete only options :test #'equal)) + (setq only (cdr only))) + (when (setq dir (assoc '|dir| options)) + (setq options (lisp::delete dir options :test #'equal)) + (setq dir (second dir)) + (when (null dir) + (|sayKeyedMsg| 'S2IU0002 nil) )) + (when (setq noexpose (assoc '|noexpose| options)) + (setq options (lisp::delete noexpose options :test #'equal)) + (setq noexpose 't) ) + (when options + (format t " Ignoring unknown )library option: ~a~%" options)) + (values only dir noexpose))) + (processDir (dirarg thisdir) + (let (allfiles skipasos) + (system:chdir (string dirarg)) + (setq allfiles (directory "*")) + (system:chdir thisdir) + (values + (mapcan #'(lambda (f) + (when (string-equal (pathname-type f) "NRLIB") + (list (concatenate 'string (namestring f) "/" + *index-filename*)))) allfiles) + (mapcan #'(lambda (f) + (when (string= (pathname-type f) "asy") + (push (pathname-name f) skipasos) + (list (namestring f)))) allfiles) + (mapcan #'(lambda (f) + (when (and (string= (pathname-type f) "ao") + (not (member (pathname-name f) skipasos :test #'string=))) + (list (namestring f)))) + allfiles) + ;; At the moment we will only look for user.lib: others are taken care + ;; of by localasy and localnrlib. +#+:CCL + (mapcan #'(lambda (f) + (when (and (string= (pathname-type f) "lib") (string= (pathname-name f) "user")) + (list (namestring f)))) + allfiles) +#-:CCL nil + )))) + (let (thisdir nrlibs asos asys libs object only dir key + (|$forceDatabaseUpdate| t) noexpose) + (declare (special |$forceDatabaseUpdate|)) + (setq thisdir (namestring (truename "."))) + (setq noexpose nil) + (multiple-value-setq (only dir noexpose) (processOptions options)) + ;don't force exposure during database build + (if make-database? (setq noexpose t)) + (when dir (multiple-value-setq (nrlibs asys asos libs) (processDir dir thisdir))) + (dolist (file filelist) + (let ((filename (pathname-name file)) + (namedir (directory-namestring file))) + (unless namedir (setq thisdir (concatenate 'string thisdir "/"))) + (cond + ((setq file (probe-file + (concatenate 'string namedir filename ".NRLIB/" + *index-filename*))) + (push (namestring file) nrlibs)) + ((setq file (probe-file + (concatenate 'string namedir filename ".asy"))) + (push (namestring file) asys)) + ((setq file (probe-file + (concatenate 'string namedir filename ".ao"))) + (push (namestring file) asos)) + ('else (format t " )library cannot find the file ~a.~%" filename))))) +#+:CCL + (dolist (file libs) (|addInputLibrary| (truename file))) + (dolist (file (nreverse nrlibs)) + (setq key (pathname-name (first (last (pathname-directory file))))) + (setq object (concatenate 'string (directory-namestring file) "code")) + (localnrlib key file object make-database? noexpose)) + (dolist (file (nreverse asys)) + (setq object + (concatenate 'string (directory-namestring file) (pathname-name file))) + (localasy (|astran| file) object only make-database? noexpose)) + (dolist (file (nreverse asos)) + (setq object + (concatenate 'string (directory-namestring file) (pathname-name file))) + (asharp file) + (setq file (|astran| (concatenate 'string (pathname-name file) ".asy"))) + (localasy file object only make-database? noexpose)) + (HCLEAR |$ConstructorCache|)))) + +(defun localasy (asy object only make-database? noexpose) + "given an alist from the asyfile and the objectfile update the database" + (labels ( + (fetchdata (alist index) + (cdr (assoc index alist :test #'string=)))) + (let (cname kind key alist (systemdir? nil) oldmaps asharp-name dbstruct abbrev) +#+:CCL + ;; Open the library + (let (lib) + (if (filep (setq lib (make-pathname :name object :type "lib")) ) + (setq input-libraries (cons (open-library (truename lib)) input-libraries)))) + (set-file-getter object) ; sets the autoload property for G-object + (dolist (domain asy) + (setq key (first domain)) + (setq alist (rest domain)) + (setq asharp-name + (foam::axiomxl-global-name (pathname-name object) key + (lassoc '|typeCode| alist))) + (if (< (length alist) 4) ;we have a naked function object + (let ((opname key) + (modemap (car (LASSOC '|modemaps| alist))) ) + (setq oldmaps (getdatabase opname 'operation)) + (setf (gethash opname *operation-hash*) + (adjoin (subst asharp-name opname (cdr modemap)) + oldmaps :test #'equal)) + (asharpMkAutoloadFunction object asharp-name)) + (when (if (null only) (not (eq key '%%)) (member key only)) + (setq *allOperations* nil) ; force this to recompute + (setq oldmaps (getdatabase key 'modemaps)) + (setq dbstruct (make-database)) + (setf (get key 'database) dbstruct) + (setq *allconstructors* (adjoin key *allconstructors*)) + (setf (database-constructorform dbstruct) + (fetchdata alist "constructorForm")) + (setf (database-constructorkind dbstruct) + (fetchdata alist "constructorKind")) + (setf (database-constructormodemap dbstruct) + (fetchdata alist "constructorModemap")) + (unless (setf (database-abbreviation dbstruct) + (fetchdata alist "abbreviation")) + (setf (database-abbreviation dbstruct) key)) ; default + (setq abbrev (database-abbreviation dbstruct)) + (setf (get abbrev 'abbreviationfor) key) + (setf (database-constructorcategory dbstruct) + (fetchdata alist "constructorCategory")) + (setf (database-attributes dbstruct) + (fetchdata alist "attributes")) + (setf (database-sourcefile dbstruct) + (fetchdata alist "sourceFile")) + (setf (database-operationalist dbstruct) + (fetchdata alist "operationAlist")) + (setf (database-modemaps dbstruct) + (fetchdata alist "modemaps")) + (setf (database-documentation dbstruct) + (fetchdata alist "documentation")) + (setf (database-predicates dbstruct) + (fetchdata alist "predicates")) + (setf (database-niladic dbstruct) + (fetchdata alist "NILADIC")) + (addoperations key oldmaps) + (setq cname (|opOf| (database-constructorform dbstruct))) + (setq kind (database-constructorkind dbstruct)) + (if (null noexpose) (|setExposeAddConstr| (cons cname nil))) + (unless make-database? + (|updateDatabase| key cname systemdir?) ;makes many hashtables??? + (|installConstructor| cname kind) + ;; following can break category database build + (if (eq kind '|category|) + (setf (database-ancestors dbstruct) + (fetchdata alist "ancestors"))) + (if (eq kind '|domain|) + (dolist (pair (cdr (assoc "ancestors" alist :test #'string=))) + (setf (gethash (cons cname (caar pair)) *hascategory-hash*) + (cdr pair)))) + (if |$InteractiveMode| (setq |$CategoryFrame| |$EmptyEnvironment|))) + (setf (database-cosig dbstruct) + (cons nil (mapcar #'|categoryForm?| + (cddar (database-constructormodemap dbstruct))))) + (setf (database-object dbstruct) (cons object asharp-name)) + (if (eq kind '|category|) + (asharpMkAutoLoadCategory object cname asharp-name + (database-cosig dbstruct)) + (asharpMkAutoLoadFunctor object cname asharp-name + (database-cosig dbstruct))) + (|sayKeyedMsg| 'S2IU0001 (list cname object)))))))) + +(defun localnrlib (key nrlib object make-database? noexpose) + "given a string pathname of an index.KAF and the object update the database" + (labels ( + (fetchdata (alist in index) + (let (pos) + (setq pos (third (assoc index alist :test #'string=))) + (when pos + (file-position in pos) + (read in))))) + (let (alist kind (systemdir? nil) pos constructorform oldmaps abbrev dbstruct) + (with-open-file (in nrlib) + (file-position in (read in)) + (setq alist (read in)) + (setq pos (third (assoc "constructorForm" alist :test #'string=))) + (file-position in pos) + (setq constructorform (read in)) + (setq key (car constructorform)) + (setq oldmaps (getdatabase key 'modemaps)) + (setq dbstruct (make-database)) + (setq *allconstructors* (adjoin key *allconstructors*)) + (setf (get key 'database) dbstruct) ; store the struct, side-effect it... + (setf (database-constructorform dbstruct) constructorform) + (setq *allOperations* nil) ; force this to recompute + (setf (database-object dbstruct) object) + (setq abbrev + (intern (pathname-name (first (last (pathname-directory object)))))) + (setf (database-abbreviation dbstruct) abbrev) + (setf (get abbrev 'abbreviationfor) key) + (setf (database-operationalist dbstruct) nil) + (setf (database-operationalist dbstruct) + (fetchdata alist in "operationAlist")) + (setf (database-constructormodemap dbstruct) + (fetchdata alist in "constructorModemap")) + (setf (database-modemaps dbstruct) (fetchdata alist in "modemaps")) + (setf (database-sourcefile dbstruct) (fetchdata alist in "sourceFile")) + (when make-database? + (setf (database-sourcefile dbstruct) + (file-namestring (database-sourcefile dbstruct)))) + (setf (database-constructorkind dbstruct) + (setq kind (fetchdata alist in "constructorKind"))) + (setf (database-constructorcategory dbstruct) + (fetchdata alist in "constructorCategory")) + (setf (database-documentation dbstruct) + (fetchdata alist in "documentation")) + (setf (database-attributes dbstruct) + (fetchdata alist in "attributes")) + (setf (database-predicates dbstruct) + (fetchdata alist in "predicates")) + (setf (database-niladic dbstruct) + (when (fetchdata alist in "NILADIC") t)) + (addoperations key oldmaps) + (unless make-database? + (if (eq kind '|category|) + (setf (database-ancestors dbstruct) + (SUBLISLIS |$FormalMapVariableList| (cdr constructorform) (fetchdata alist in "ancestors")))) + (|updateDatabase| key key systemdir?) ;makes many hashtables??? + (|installConstructor| key kind) ;used to be key cname ... + (|updateCategoryTable| key kind) + (if |$InteractiveMode| (setq |$CategoryFrame| |$EmptyEnvironment|))) + (setf (database-cosig dbstruct) + (cons nil (mapcar #'|categoryForm?| + (cddar (database-constructormodemap dbstruct))))) + (remprop key 'loaded) + (if (null noexpose) (|setExposeAddConstr| (cons key nil))) + #-:CCL + (setf (symbol-function key) ; sets the autoload property for cname + #'(lambda (&rest args) + (unless (get key 'loaded) + (|startTimingProcess| '|load|) + (|loadLibNoUpdate| key key object)) ; used to be cname key + (apply key args))) + #+:CCL + (let (lib) + (if (filep (setq lib (make-pathname :name object :type "lib")) ) + (setq input-libraries (cons (open-library (truename lib)) input-libraries))) + (|unloadOneConstructor| (get abbrev 'abbreviationfor) abbrev) ) + (|sayKeyedMsg| 'S2IU0001 (list key object)))))) + + +; making new databases consists of: +; 1) reset all of the system hash tables +; *) set up Union, Record and Mapping +; 2) map )library across all of the system files (fills the databases) +; 3) loading some normally autoloaded files +; 4) making some database entries that are computed (like ancestors) +; 5) writing out the databases +; 6) write out 'warm' data to be loaded into the image at build time +; note that this process should be done in a clean image +; followed by a rebuild of the system image to include +; the new index pointers (e.g. *interp-stream-stamp*) +; the system will work without a rebuild but it needs to +; re-read the databases on startup. rebuilding the system +; will cache the information into the image and the databases +; are opened but not read, saving considerable startup time. +; also note that the order the databases are written out is +; critical. interp.daase depends on prior computations and has +; to be written out last. + +(defun make-databases (ext dirlist) + (labels ( + ;; these are types which have no library object associated with them. + ;; we store some constructed data to make them perform like library + ;; objects, the *operationalist-hash* key entry is used by allConstructors + (withSpecialConstructors () + ; note: if item is not in *operationalist-hash* it will not be written + ; Category + (setf (get '|Category| 'database) + (make-database :operationalist nil :niladic t)) + (push '|Category| *allconstructors*) + ; UNION + (setf (get '|Union| 'database) + (make-database :operationalist nil :constructorkind '|domain|)) + (push '|Union| *allconstructors*) + ; RECORD + (setf (get '|Record| 'database) + (make-database :operationalist nil :constructorkind '|domain|)) + (push '|Record| *allconstructors*) + ; MAPPING + (setf (get '|Mapping| 'database) + (make-database :operationalist nil :constructorkind '|domain|)) + (push '|Mapping| *allconstructors*) + ; ENUMERATION + (setf (get '|Enumeration| 'database) + (make-database :operationalist nil :constructorkind '|domain|)) + (push '|Enumeration| *allconstructors*) + ) + (final-name (root) + (format nil "~a.daase~a" root ext)) + ) + (let (d) + (declare (special |$constructorList|)) + (do-symbols (symbol) + (when (get symbol 'database) + (setf (get symbol 'database) nil))) + (setq *hascategory-hash* (make-hash-table :test #'equal)) + (setq *operation-hash* (make-hash-table)) + (setq *allconstructors* nil) + (setq *compressvector* nil) + (withSpecialConstructors) + (localdatabase nil + (list (list '|dir| (namestring (truename "./")) )) + 'make-database) + (dolist (dir dirlist) + (localdatabase nil + (list (list '|dir| + (namestring (probe-file + (format nil "./~a" + dir))))) + 'make-database)) +#+:AKCL (|mkTopicHashTable|) + (setq |$constructorList| nil) ;; affects buildLibdb + (|buildLibdb|) + (|dbSplitLibdb|) +; (|dbAugmentConstructorDataTable|) + (|mkUsersHashTable|) + (|saveUsersHashTable|) + (|mkDependentsHashTable|) + (|saveDependentsHashTable|) +; (|buildGloss|) + (write-compress) + (write-browsedb) + (write-operationdb) + ; note: genCategoryTable creates a new *hascategory-hash* table + ; this smashes the existing table and regenerates it. + ; write-categorydb does getdatabase calls to write the new information + (write-categorydb) + (dolist (con (|allConstructors|)) + (let (dbstruct) + (when (setq dbstruct (get con 'database)) + (setf (database-cosig dbstruct) + (cons nil (mapcar #'|categoryForm?| + (cddar (database-constructormodemap dbstruct))))) + (when (and (|categoryForm?| con) + (= (length (setq d (|domainsOf| (list con) NIL NIL))) 1)) + (setq d (caar d)) + (when (= (length d) (length (|getConstructorForm| con))) + (format t " ~a has a default domain of ~a~%" con (car d)) + (setf (database-defaultdomain dbstruct) (car d))))))) + ; note: genCategoryTable creates *ancestors-hash*. write-interpdb + ; does gethash calls into it rather than doing a getdatabase call. + (write-interpdb) +#+:AKCL (write-warmdata) + (create-initializers) + (when (probe-file (final-name "compress")) + (delete-file (final-name "compress"))) + (rename-file "compress.build" (final-name "compress")) + (when (probe-file (final-name "interp")) + (delete-file (final-name "interp"))) + (rename-file "interp.build" (final-name "interp")) + (when (probe-file (final-name "operation")) + (delete-file (final-name "operation"))) + (rename-file "operation.build" (final-name "operation")) + (when (probe-file (final-name "browse")) + (delete-file (final-name "browse"))) + (rename-file "browse.build" + (final-name "browse")) + (when (probe-file (final-name "category")) + (delete-file (final-name "category"))) + (rename-file "category.build" + (final-name "category"))))) + +(defun DaaseName (name erase?) + (let (daase filename) + (if (setq daase (|systemAlgebraDirectory|)) + (progn + (setq filename (concatenate 'string daase name)) + (format t " Using local database ~a.." filename)) + (setq filename (concatenate 'string + (|systemRootDirectory|) + "/algebra/" + name))) + (when erase? (system::system (concatenate 'string "rm -f " filename))) + filename)) + +;; rewrite this so it works in mnt +;;(defun DaaseName (name erase?) +;; (let (daase filename) +;; (declare (special $spadroot)) +;; (if (setq daase (|getEnv| "DAASE")) +;; (progn +;; (setq filename (concatenate 'string daase "/algebra/" name)) +;; (format t " Using local database ~a.." filename)) +;; (setq filename (concatenate 'string $spadroot "/algebra/" name))) +;; (when erase? (system::system (concatenate 'string "rm -f " filename))) +;; filename)) + + +(defun compressOpen () + (let (lst stamp pos) + (setq *compress-stream* + (open (DaaseName "compress.daase" nil) :direction :input)) + (setq stamp (read *compress-stream*)) + (unless (equal stamp *compress-stream-stamp*) + (format t " Re-reading compress.daase") + (setq *compress-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *compress-stream* pos) + (setq lst (read *compress-stream*)) + (setq *compressVectorLength* (car lst)) + (setq *compressvector* + (make-array (car lst) :initial-contents (cdr lst)))))) + +(defun write-compress () + (let (compresslist masterpos out) + (close *compress-stream*) + (setq out (open "compress.build" :direction :output)) + (princ " " out) + (finish-output out) + (setq masterpos (file-position out)) + (setq compresslist + (append (|allConstructors|) (|allOperations|) *attributes*)) + (push "algebra" compresslist) + (push "failed" compresslist) + (push 'signature compresslist) + (push '|ofType| compresslist) + (push '|Join| compresslist) + (push 'and compresslist) + (push '|nobranch| compresslist) + (push 'category compresslist) + (push '|category| compresslist) + (push '|domain| compresslist) + (push '|package| compresslist) + (push 'attribute compresslist) + (push '|isDomain| compresslist) + (push '|ofCategory| compresslist) + (push '|Union| compresslist) + (push '|Record| compresslist) + (push '|Mapping| compresslist) + (push '|Enumeration| compresslist) + (setq *compressVectorLength* (length compresslist)) + (setq *compressvector* + (make-array *compressVectorLength* :initial-contents compresslist)) + (print (cons (length compresslist) compresslist) out) + (finish-output out) + (file-position out 0) + (print (cons masterpos (get-universal-time)) out) + (finish-output out) + (close out))) + +(defun write-interpdb () + "build interp.daase from hash tables" + (declare (special *ancestors-hash*)) + (let (opalistpos modemapspos cmodemappos master masterpos obj *print-pretty* + concategory categorypos kind niladic cosig abbrev defaultdomain + ancestors ancestorspos out) + (declare (special *print-pretty*)) + (print "building interp.daase") + (setq out (open "interp.build" :direction :output)) + (princ " " out) + (finish-output out) + (dolist (constructor (|allConstructors|)) + (let (struct) + (setq struct (get constructor 'database)) + (setq opalistpos (file-position out)) + (print (squeeze (database-operationalist struct)) out) + (finish-output out) + (setq cmodemappos (file-position out)) + (print (squeeze (database-constructormodemap struct)) out) + (finish-output out) + (setq modemapspos (file-position out)) + (print (squeeze (database-modemaps struct)) out) + (finish-output out) + (if (consp (database-object struct)) ; if asharp code ... + (setq obj + (cons (pathname-name (car (database-object struct))) + (cdr (database-object struct)))) + (setq obj + (pathname-name + (first (last (pathname-directory (database-object struct))))))) + (setq concategory (squeeze (database-constructorcategory struct))) + (if concategory ; if category then write data else write nil + (progn + (setq categorypos (file-position out)) + (print concategory out) + (finish-output out)) + (setq categorypos nil)) + (setq niladic (database-niladic struct)) + (setq abbrev (database-abbreviation struct)) + (setq cosig (database-cosig struct)) + (setq kind (database-constructorkind struct)) + (setq defaultdomain (database-defaultdomain struct)) + (setq ancestors (squeeze (gethash constructor *ancestors-hash*))) ;cattable.boot + (if ancestors + (progn + (setq ancestorspos (file-position out)) + (print ancestors out) + (finish-output out)) + (setq ancestorspos nil)) + (push (list constructor opalistpos cmodemappos modemapspos + obj categorypos niladic abbrev cosig kind defaultdomain + ancestorspos) master))) + (finish-output out) + (setq masterpos (file-position out)) + (print (mapcar #'squeeze master) out) + (finish-output out) + (file-position out 0) + (print (cons masterpos (get-universal-time)) out) + (finish-output out) + (close out))) + +(defun write-browsedb () + "make browse.daase from hash tables" + (let (master masterpos src formpos docpos attpos predpos *print-pretty* out) + (declare (special *print-pretty*)) + (print "building browse.daase") + (setq out (open "browse.build" :direction :output)) + (princ " " out) + (finish-output out) + (dolist (constructor (|allConstructors|)) + (let (struct) + (setq struct (get constructor 'database)) + ; sourcefile is small. store the string directly + (setq src (database-sourcefile struct)) + (setq formpos (file-position out)) + (print (squeeze (database-constructorform 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 (database-attributes struct)) out) + (finish-output out) + (setq predpos (file-position out)) + (print (squeeze (database-predicates struct)) out) + (finish-output out) + (push (list constructor src formpos docpos attpos predpos) master))) + (finish-output out) + (setq masterpos (file-position out)) + (print (mapcar #'squeeze master) out) + (finish-output out) + (file-position out 0) + (print (cons masterpos (get-universal-time)) out) + (finish-output out) + (close out))) + +(defun write-categorydb () + "make category.daase from scratch. contains the *hasCategory-hash* table" + (let (out master pos *print-pretty*) + (declare (special *print-pretty*)) + (print "building category.daase") + (|genCategoryTable|) + (setq out (open "category.build" :direction :output)) + (princ " " out) + (finish-output out) + (maphash #'(lambda (key value) + (if (or (null value) (eq value t)) + (setq pos value) + (progn + (setq pos (file-position out)) + (print (squeeze value) out) + (finish-output out))) + (push (list key pos) master)) + *hasCategory-hash*) + (setq pos (file-position out)) + (print (mapcar #'squeeze master) out) + (finish-output out) + (file-position out 0) + (print (cons pos (get-universal-time)) out) + (finish-output out) + (close out))) + +(defun unsqueeze (expr) + (cond ((atom expr) + (cond ((and (numberp expr) (<= expr 0)) + (svref *compressVector* (- expr))) + (t expr))) + (t (rplaca expr (unsqueeze (car expr))) + (rplacd expr (unsqueeze (cdr expr))) + expr))) + +(defun squeeze (expr) + (let (leaves pos (bound (length *compressvector*))) + (labels ( + (flat (expr) + (when (and (numberp expr) (< expr 0) (>= expr bound)) + (print expr) + (break "squeeze found a negative number")) + (if (atom expr) + (unless (or (null expr) + (and (symbolp expr) (char= (schar (symbol-name expr) 0) #\*))) + (setq leaves (adjoin expr leaves))) + (progn + (flat (car expr)) + (flat (cdr expr)))))) + (setq leaves nil) + (flat expr) + (dolist (leaf leaves) + (when (setq pos (position leaf *compressvector*)) + (nsubst (- pos) leaf expr))) + expr))) + +(defun write-operationdb () + (let (pos master out) + (declare (special leaves)) + (setq out (open "operation.build" :direction :output)) + (princ " " out) + (finish-output out) + (maphash #'(lambda (key value) + (setq pos (file-position out)) + (print (squeeze value) out) + (finish-output out) + (push (cons key pos) master)) + *operation-hash*) + (finish-output out) + (setq pos (file-position out)) + (print (mapcar #'squeeze master) out) + (file-position out 0) + (print (cons pos (get-universal-time)) out) + (finish-output out) + (close out))) + +(defun write-warmdata () + "write out information to be loaded into the image at build time" + (declare (special |$topicHash|)) + (with-open-file (out "warm.data" :direction :output) + (format out "(in-package \"BOOT\")~%") + (format out "(setq |$topicHash| (make-hash-table))~%") + (maphash #'(lambda (k v) + (format out "(setf (gethash '|~a| |$topicHash|) ~a)~%" k v)) |$topicHash|))) + +(defun |allConstructors| () + (declare (special *allconstructors*)) + *allconstructors*) + +(defun |allOperations| () + (declare (special *allOperations*)) + (unless *allOperations* + (maphash #'(lambda (k v) (declare (ignore v)) (push k *allOperations*)) + *operation-hash*)) + *allOperations*) + +; the variable NOPfuncall is a funcall-able object that is a dummy +; initializer for libaxiom asharp domains. +(defvar NOPfuncall (cons 'identity nil)) + +(defun create-initializers () +;; since libaxiom is now built with -name=axiom following unnecessary +;; (dolist (con (|allConstructors|)) +;; (let ((sourcefile (getdatabase con 'sourcefile))) +;; (if sourcefile +;; (set (foam::axiomxl-file-init-name (pathname-name sourcefile)) +;; NOPfuncall)))) + (set (foam::axiomxl-file-init-name "axiom") NOPfuncall) +;; (set (foam::axiomxl-file-init-name "axclique") NOPfuncall) + (set (foam::axiomxl-file-init-name "filecliq") NOPfuncall) + (set (foam::axiomxl-file-init-name "attrib") NOPfuncall) +;; following needs to happen inside restart since $AXIOM may change + (let ((asharprootlib (strconc (|systemRootDirectory|) "/aldor/lib/"))) + (set-file-getter (strconc asharprootlib "runtime")) + (set-file-getter (strconc asharprootlib "lang")) + (set-file-getter (strconc asharprootlib "attrib")) + (set-file-getter (strconc asharprootlib "axlit")) + (set-file-getter (strconc asharprootlib "minimach")) + (set-file-getter (strconc asharprootlib "axextend")))) + + + +;--------------------------------------------------------------------- + +; how the magic works: +; when a )library is done on a new compiler file we set up multiple +; functions (refered to as autoloaders). there is an autoloader +; stored in the symbol-function of the G-filename (e.g. G-basic) +; (see set-file-getter function) +; and an autoloader stored in the symbol-function of every domain +; in the basic.as file ( asharpMkAutoloadFunctor ) +; When a domain is needed the autoloader for the domain is executed. +; this autoloader invokes file-getter-name to get the name of the +; file (eg basic) and evaluates the name. the FIRST time this is done +; for a file the file will be loaded by its autoloader, then it will +; return the file object. every other time the file is already +; loaded and the file object is returned directly. +; Once the file object is gotten getconstructor is called to get the +; domain. the FIRST time this is done for the domain the autoloader +; invokes the file object. every other time the domain already +; exists. +;(defvar *this-file* "no-file") + +(defmacro |CCall| (fun &rest args) + (let ((ccc (gensym)) (cfun (gensym)) (cenv (gensym))) + `(let ((,ccc ,fun)) + (let ((,cfun (|ClosFun| ,ccc)) + (,cenv (|ClosEnv| ,ccc))) + (funcall ,cfun ,@args ,cenv ))))) + +(defmacro |ClosFun| (x) `(car ,x)) +(defmacro |ClosEnv| (x) `(cdr ,x)) + +(defun file-runner (name) + (declare (special foam-user::|G-domainPrepare!|)) + (|CCall| foam-user::|G-domainPrepare!| (|CCall| name))) + +(defun getConstructor (file-fn asharp-name) + (|CCall| file-fn) +; (eval (cdr (assoc file-id (get name 'asharp-name) :test #'equal)))) + (eval asharp-name)) + +(defun getop (dom op type) + (declare (special foam-user::|G-domainGetExport!|)) + (|CCall| foam-user::|G-domainGetExport!| dom + (|hashString| (symbol-name op)) type)) + +; the asharp compiler will allow both constant domains and domains +; which are functions. localasy sets the autoload property so that +; the symbol-function contains a function that, when invoked with +; the correct number of args will return a domain. + +; this function is called if we are given a new compiler domain +; which is a function. the symbol-function of the domain is set +; to call the function with the correct number of arguments. + +(defun wrapDomArgs (obj type?) + (cond ((not type?) obj) + (t (|makeOldAxiomDispatchDomain| obj)))) + +;; CCL doesn't have closures, so we use an intermediate function in +;; asharpMkAutoLoadFunctor. +#+:CCL +(defun mkFunctorStub (func cosig cname) + (setf (symbol-function cname) + (if (vectorp (car func)) + `(lambda () ',func) ;; constant domain + `(lambda (&rest args2) + (apply ',(|ClosFun| func) + (nconc + (mapcar #'wrapDomArgs args2 ',(cdr cosig)) + (list ',(|ClosEnv| func)))))))) + +#+:CCL +(defun asharpMkAutoLoadFunctor (file cname asharp-name cosig) + (setf (symbol-function cname) + `(lambda (&rest args) + (mkFunctorStub + (getconstructor (eval (file-getter-name ',file)) ',asharp-name) + ',cosig ',cname) + (apply ',cname args)))) + +#-:CCL +(defun asharpMkAutoLoadFunctor (file cname asharp-name cosig) + (setf (symbol-function cname) + #'(lambda (&rest args) + (let ((func (getconstructor (eval (file-getter-name file)) asharp-name))) + (setf (symbol-function cname) + (if (vectorp (car func)) + #'(lambda () func) ;; constant domain + #'(lambda (&rest args) + (apply (|ClosFun| func) + (nconc + (mapcar #'wrapDomArgs args (cdr cosig)) + (list (|ClosEnv| func))))))) + (apply cname args))))) + +;; CCL doesn't have closures, so we use an intermediate function in +;; asharpMkAutoLoadCategory. +#+:CCL +(defun mkCategoryStub (func cosig packname) + (setf (symbol-function packname) + (if (vectorp (car func)) + `(lambda (self) ;; constant category + (|CCall| (elt ',(car func) 5) ',(cdr func) (wrapDomArgs self t))) + `(lambda (self &rest args) + (let ((precat + (apply (|ClosFun| ',func) + (nconc + (mapcar #'wrapDomArgs args ',(cdr cosig)) + (list (|ClosEnv| ',func)))))) + (|CCall| (elt (car precat) 5) (cdr precat) (wrapDomArgs self t))))) +)) + +#+:CCL +(defun asharpMkAutoLoadCategory (file cname asharp-name cosig) + (asharpMkAutoLoadFunctor file cname asharp-name cosig) + (let ((packname (INTERN (STRCONC cname "&")))) + (setf (symbol-function packname) + `(lambda (self &rest args) + (mkCategoryStub + (getconstructor (eval (file-getter-name ',file)) ',asharp-name) + ',cosig ',packname) + (apply ',packname self args))))) + +#-:CCL +(defun asharpMkAutoLoadCategory (file cname asharp-name cosig) + (asharpMkAutoLoadFunctor file cname asharp-name cosig) + (let ((packname (INTERN (STRCONC cname '"&")))) + (setf (symbol-function packname) + #'(lambda (self &rest args) + (let ((func (getconstructor (eval (file-getter-name file)) asharp-name))) + (setf (symbol-function packname) + (if (vectorp (car func)) + #'(lambda (self) + (|CCall| (elt (car func) 5) (cdr func) (wrapDomArgs self t))) ;; constant category + #'(lambda (self &rest args) + (let ((precat + (apply (|ClosFun| func) + (nconc + (mapcar #'wrapDomArgs args (cdr cosig)) + (list (|ClosEnv| func)))))) + (|CCall| (elt (car precat) 5) (cdr precat) (wrapDomArgs self t)))))) + (apply packname self args)))))) + +#+:CCL +(defun asharpMkAutoLoadFunction (file asharpname) + (set asharpname + (cons + `(lambda (&rest l) + (let ((args (butlast l)) + (func (getconstructor (eval (file-getter-name ',file)) ',asharpname))) + (apply (car func) (append args (list (cdr func)))))) + ()))) + +#-:CCL +(defun asharpMkAutoLoadFunction (file asharpname) + (set asharpname + (cons + #'(lambda (&rest l) + (let ((args (butlast l)) + (func (getconstructor (eval (file-getter-name file)) asharpname))) + (apply (car func) (append args (list (cdr func)))))) + ()))) + +; this function will return the internal name of the file object getter + +(defun file-getter-name (filename) + (foam::axiomxl-file-init-name (pathname-name filename))) + +;;need to initialize |G-filename| to a function which loads file +;; and then returns the new value of |G-filename| + +(defun set-file-getter (filename) + (let ((getter-name (file-getter-name filename))) + (set getter-name + (cons #'init-file-getter (cons getter-name filename))))) + +(defun init-file-getter (env) + (let ((getter-name (car env)) + (filename (cdr env))) +#-:CCL + (load filename) +#+:CCL + (load-module filename) + (|CCall| (eval getter-name)))) + +(defun set-lib-file-getter (filename cname) + (let ((getter-name (file-getter-name filename))) + (set getter-name + (cons #'init-lib-file-getter (cons getter-name cname))))) + +(defun init-lib-file-getter (env) + (let* ((getter-name (car env)) + (cname (cdr env)) + (filename (getdatabase cname 'object))) +#-:CCL + (load filename) +#+:CCL + (load-module (pathname-name filename)) + (|CCall| (eval getter-name)))) + +;; following 2 functions are called by file-exports and file-imports macros +(defun foam::process-import-entry (entry) + (let* ((asharpname (car entry)) + (stringname (cadr entry)) + (hcode (caddr entry)) + (libname (cadddr entry)) + (bootname (intern stringname 'boot))) + (declare (ignore libname)) + (if (and (eq hcode 'foam-user::|initializer|) (not (boundp asharpname))) + (error (format nil "AxiomXL file ~s is missing!" stringname))) + (unless (or (not (numberp hcode)) (zerop hcode) (boundp asharpname)) + (when (|constructor?| bootname) + (set asharpname + (if (getdatabase bootname 'niladic) + (|makeLazyOldAxiomDispatchDomain| (list bootname)) + (cons '|runOldAxiomFunctor| bootname)))) + (when (|attribute?| bootname) + (set asharpname (|makeLazyOldAxiomDispatchDomain| bootname)))))) + + + +;(defun foam::process-export-entry (entry) +; (let* ((asharpname (car entry)) +; (stringname (cadr entry)) +; (hcode (caddr entry)) +; (libname (cadddr entry)) +; (bootname (intern stringname 'boot))) +; (declare (ignore libname)) +; (when (numberp hcode) +; (setf (get bootname 'asharp-name) +; (cons (cons *this-file* asharpname) +; (get bootname 'asharp-name))) +; ))) + + + + + + + |