path: root/src/interp/daase.lisp

;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
;; Copyright (C) 2007-2008, 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

(import-module "macros")
(in-package "AxiomCore")
(import-module "foam_l")
(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 *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"
 (|runProgram|
   (concatenate 'string (|systemRootDirectory|) "/compiler/bin/axiomxl")
    (list 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 (|getSystemModulePath| (string (getdatabase con 'abbreviation)))))
    (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 (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)) "")
                 (|getSystemModulePath| (car data))
               (car data)))
      (when (and data (string= (directory-namestring data) ""))
       (setq data (|getSystemModulePath| data)))))))
  data))

; )library top level command  -- soon to be obsolete

;; Current directory
;; Contributed by Juergen Weiss.
#+:cmu
(defun get-current-directory ()
  (namestring (extensions::default-directory)))

#+(or :akcl :gcl :clisp :sbcl)
(defun get-current-directory ()
  (namestring (truename "")))

  
; 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 (delete only options :test #'equal))
			(setq only (cdr only)))
		      (when (setq dir (assoc '|dir| options))
			(setq options (delete dir options :test #'equal))
			(setq dir (second dir))
			(when (null dir)
			  (|sayKeyedMsg| 'S2IU0002 nil) ))
		      (when (setq noexpose (assoc '|noexpose| options))
			(setq options (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)
		(|changeDirectory| (string dirarg))
		(let ((indexFiles (|getAllIndexPathnames|))
		      (aldorFiles (|getAllAldorObjectFiles|)))
		  (|changeDirectory| thisdir)
		  (values
		   indexFiles
		   (first aldorFiles)
		   (second aldorFiles)
		   ;; At the moment we will only look for user.lib: others 
		   ;; are taken care of by localasy and localnrlib.
		   nil
		   ))))
   (let (thisdir nrlibs asos asys libs object only dir key 
		 (|$forceDatabaseUpdate| t) noexpose)
     (declare (special |$forceDatabaseUpdate|))
     (setq thisdir (get-current-directory))
     (setq noexpose nil)
     (multiple-value-setq (only dir noexpose) (processOptions options))
     ;don't force exposure during database build
     (if make-database? 
	 (setq noexpose t))
     (if 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/"
				    |$IndexFilename|)))
	   (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)))))
     (dolist (file (nreverse nrlibs))
       (setq key (pathname-name (first (last (pathname-directory file)))))
       (setq object (concatenate 'string 
				 (directory-namestring file) 
				 "code." |$faslType|))
       (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 (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
   ; 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) 
	      (concat root ".daase"))
  )
 (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| (get-current-directory) ))
     'make-database)
  (dolist (dir dirlist)
          (localdatabase nil 
                         (list (list '|dir| 
                                     (namestring (probe-file 
                                                  (concat "./" 
                                                          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? (|removeFile| 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? (|removeFile| 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)
  (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)
    (let ((entry (database-object struct)))
      (cond ((consp entry)
	     (setq obj (cons (pathname-name (car entry))
			     (cdr entry))))
	    (entry
	     (setq obj (pathname-name
			(first (last (pathname-directory entry))))))
	    (t (setq obj nil))))
    (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 (|squeezeAll| 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)
  (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 (|squeezeAll| 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*)
  (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 (|squeezeAll| 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 (|squeezeAll| 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))))
 (setf (symbol-value (foam::axiomxl-file-init-name "axiom")) NOPfuncall)
;; (set (foam::axiomxl-file-init-name "axclique") NOPfuncall)
 (setf (symbol-value (foam::axiomxl-file-init-name "filecliq")) NOPfuncall)
 (setf (symbol-value (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)
 (setf (symbol-value 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)
  (setf (symbol-value 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)))
    (setf (symbol-value 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)))
    (setf (symbol-value 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)
                (setf (symbol-value asharpname)
                     (if (getdatabase bootname 'niladic)
                         (|makeLazyOldAxiomDispatchDomain| (list bootname))
                       (cons '|runOldAxiomFunctor|  bootname))))
          (when (|attribute?| bootname)
                (setf (symbol-value 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)))
;         )))