diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/br-con.boot | 3 | ||||
| -rw-r--r-- | src/interp/br-saturn.boot | 2 | ||||
| -rw-r--r-- | src/interp/br-util.boot | 9 | ||||
| -rw-r--r-- | src/interp/daase.lisp | 114 | ||||
| -rw-r--r-- | src/interp/database.boot | 15 | ||||
| -rw-r--r-- | src/interp/g-cndata.boot | 8 | ||||
| -rw-r--r-- | src/interp/spad-parser.boot | 9 | ||||
| -rw-r--r-- | src/interp/sys-driver.boot | 12 |
8 files changed, 107 insertions, 65 deletions
diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot index f2b87dd3..2b8f5cd9 100644 --- a/src/interp/br-con.boot +++ b/src/interp/br-con.boot @@ -116,7 +116,6 @@ kdPageInfo(name,abbrev,nargs,conform,signature,file?) == htSayStandard '"\indentrel{-2}" if isDefautPackageName makeSymbol name then name := subSequence(name, 0, #name-1) ---sourceFileName := dbSourceFile makeSymbol name sourceFileName := getConstructorSourceFileFromDB makeSymbol name filename := extractFileNameFromPath sourceFileName if filename ~= '"" then @@ -692,7 +691,7 @@ conOpPage1(conform,:options) == conform := mkConform(kind,name,args) capitalKind := capitalize kind signature := ncParseFromString sig - sourceFileName := dbSourceFile makeSymbol name + sourceFileName := getContructorSourceFileFromDB makeSymbol name emString := ['"{\sf ",constring,'"}"] heading := [capitalKind,'" ",:emString] if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] diff --git a/src/interp/br-saturn.boot b/src/interp/br-saturn.boot index 1cfb4703..547b193c 100644 --- a/src/interp/br-saturn.boot +++ b/src/interp/br-saturn.boot @@ -626,7 +626,7 @@ kPage(line,:options) == --any cat, dom, package, default package conname := opOf conform capitalKind := capitalize kind signature := ncParseFromString sig - sourceFileName := dbSourceFile makeSymbol name + sourceFileName := getConstructorSourceFileFromDB makeSymbol name constrings := KDR form => dbConformGenUnder form [strconc(name,args)] diff --git a/src/interp/br-util.boot b/src/interp/br-util.boot index 873dfa56..7e8f6830 100644 --- a/src/interp/br-util.boot +++ b/src/interp/br-util.boot @@ -347,13 +347,6 @@ bcStarConform form == bcStar opOf form bcConform form -dbSourceFile name == - u:= getConstructorSourceFileFromDB name - null u => '"" - n := PATHNAME_-NAME u - t := PATHNAME_-TYPE u - strconc(n,'".",t) - extractFileNameFromPath s == fn(s,0,#s) where fn(s,i,m) == k := charPosition(char "/",s,i) @@ -491,7 +484,7 @@ dbSayItems(countOrPrefix,singular,plural,:options) == if count ~= 0 then bcHt '":" dbBasicConstructor? conname == - dbSourceFile conname in '("catdef" "coerce") + getConstructorSourceFileFromDB conname in '("catdef" "coerce") nothingFoundPage(:options) == htInitPage('"Sorry, no match found",nil) diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp index 74b6ba9c..50b6b63e 100644 --- a/src/interp/daase.lisp +++ b/src/interp/daase.lisp @@ -232,6 +232,9 @@ (defmacro |dbAbbreviation| (db) `(database-abbreviation ,db)) +(defmacro |dbConstructor| (db) + `(database-constructor ,db)) + (defmacro |dbConstructorKind| (db) `(database-constructorkind ,db)) @@ -241,12 +244,44 @@ (defmacro |dbOperations| (db) `(database-operationalist ,db)) +(defmacro |dbModemaps| (db) + `(database-modemaps ,db)) + (defmacro |dbConstructorModemap| (db) `(database-constructormodemap ,db)) +(defmacro |dbDualSignature| (db) + `(database-cosig ,db)) + (defmacro |dbSuperDomain| (db) `(database-superdomain ,db)) +(defmacro |dbCategory| (db) + `(database-constructorcategory ,db)) + +(defmacro |dbAncestors| (db) + `(database-ancestors ,db)) + +(defmacro |dbDefaultDomain| (db) + `(database-defaultdomain ,db)) + +(defmacro |dbAttributes| (db) + `(database-attributes ,db)) + +(defmacro |dbPredicates| (db) + `(database-predicates ,db)) + +(defmacro |dbSourceFile| (db) + `(database-sourcefile ,db)) + +(defmacro |dbModule| (db) + `(database-object ,db)) + +(defun |makeDB| (c) + (let ((db (make-database))) + (setf (|dbConstructor| db) c) + (setf (|constructorDB| c) db))) + ; 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. @@ -591,14 +626,14 @@ (setf (|constructorDB| (car item)) dbstruct) (setf (|dbOperations| dbstruct) (second item)) (setf (|dbConstructorModemap| dbstruct) (third item)) - (setf (database-modemaps dbstruct) (fourth item)) - (setf (database-object dbstruct) (fifth item)) - (setf (database-constructorcategory dbstruct) (sixth item)) + (setf (|dbModemaps| dbstruct) (fourth item)) + (setf (|dbModule| dbstruct) (fifth item)) + (setf (|dbCategory| dbstruct) (sixth item)) (setf (|dbAbbreviation| dbstruct) (seventh item)) (setf (get (seventh item) 'abbreviationfor) (first item)) ;invert - (setf (database-cosig dbstruct) (eighth item)) + (setf (|dbDualSignature| dbstruct) (eighth item)) (setf (|dbConstructorKind| dbstruct) (ninth item)) - (setf (database-ancestors dbstruct) (nth 10 item)) + (setf (|dbAncestors| dbstruct) (nth 10 item)) (setf (|dbSuperDomain| dbstruct) (nth 11 item)) )) @@ -655,8 +690,8 @@ (setf (database-sourcefile dbstruct) (second item)) (setf (|dbConstructorForm| dbstruct) (third item)) (setf (database-documentation dbstruct) (fourth item)) - (setf (database-attributes dbstruct) (fifth item)) - (setf (database-predicates dbstruct) (sixth item)) + (setf (|dbAttributes| dbstruct) (fifth item)) + (setf (|dbPredicates| dbstruct) (sixth item)) (setf (database-parents dbstruct) (seventh item)))) (format t "~&"))) @@ -758,8 +793,7 @@ (let (struct) (when (symbolp constructor) (unless (setq struct (|constructorDB| constructor)) - (setq struct (make-database)) - (setf (|constructorDB| constructor) struct)) + (setq struct (|makeDB| constructor))) (case key (abbreviation (setf (|dbAbbreviation| struct) value) @@ -798,7 +832,7 @@ (cosig (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-cosig struct)))) + (setq data (|dbDualSignature| struct)))) (operation (setq stream *operation-stream*) (setq data (gethash constructor *operation-hash*))) @@ -809,7 +843,7 @@ (constructorcategory (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-constructorcategory struct)) + (setq data (|dbCategory| struct)) (when (null data) ;domain or package then subfield of constructormodemap (setq data (cadar (|getConstructorModemap| constructor)))))) (operationalist @@ -819,7 +853,7 @@ (modemaps (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-modemaps struct)))) + (setq data (|dbModemaps| struct)))) (hascategory (setq table *hasCategory-hash*) (setq stream *category-stream*) @@ -827,7 +861,7 @@ (object (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-object struct)))) + (setq data (|dbModule| struct)))) (constructor? (|fatalError| "GETDATABASE called with CONSTRUCTOR?")) (superdomain @@ -841,7 +875,7 @@ (ancestors (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-ancestors struct)))) + (setq data (|dbAncestors| struct)))) (sourcefile (setq stream *browse-stream*) (when (setq struct (|constructorDB| constructor)) @@ -855,11 +889,11 @@ (attributes (setq stream *browse-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-attributes struct)))) + (setq data (|dbAttributes| struct)))) (predicates (setq stream *browse-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-predicates struct)))) + (setq data (|dbPredicates| struct)))) (documentation (setq stream *browse-stream*) (when (setq struct (|constructorDB| constructor)) @@ -896,29 +930,29 @@ (constructorkind (setf (|dbConstructorKind| struct) data)) (cosig - (setf (database-cosig struct) data)) + (setf (|dbDualSignature| struct) data)) (constructormodemap (setf (|dbConstructorModemap| struct) data)) (constructorcategory - (setf (database-constructorcategory struct) data)) + (setf (|dbCategory| struct) data)) (operationalist (setf (|dbOperations| struct) data)) (modemaps - (setf (database-modemaps struct) data)) + (setf (|dbModemaps| struct) data)) (object - (setf (database-object struct) data)) + (setf (|dbModule| struct) data)) (abbreviation (setf (|dbAbbreviation| struct) data)) (constructor - (setf (database-constructor struct) data)) + (setf (|dbConstructor| struct) data)) (ancestors - (setf (database-ancestors struct) data)) + (setf (|dbAncestors| struct) data)) (constructorform (setf (|dbConstructorForm| struct) data)) (attributes - (setf (database-attributes struct) data)) + (setf (|dbAttributes| struct) data)) (predicates - (setf (database-predicates struct) data)) + (setf (|dbPredicates| struct) data)) (documentation (setf (database-documentation struct) data)) (parents @@ -1050,7 +1084,7 @@ (setf (|constructorDB| key) dbstruct) ; store the struct, side-effect it... (setf (|dbConstructorForm| dbstruct) constructorform) (setq *allOperations* nil) ; force this to recompute - (setf (database-object dbstruct) object) + (setf (|dbModule| dbstruct) object) (setq abbrev (intern (pathname-name (first (last (pathname-directory object)))))) (setf (|dbAbbreviation| dbstruct) abbrev) @@ -1060,7 +1094,7 @@ (fetchdata alist in "operationAlist")) (setf (|dbConstructorModemap| dbstruct) (fetchdata alist in "constructorModemap")) - (setf (database-modemaps dbstruct) + (setf (|dbModemaps| dbstruct) (fetchdata alist in "modemaps")) (setf (database-sourcefile dbstruct) (fetchdata alist in "sourceFile")) @@ -1069,20 +1103,20 @@ (file-namestring (database-sourcefile dbstruct)))) (setf (|dbConstructorKind| dbstruct) (setq kind (fetchdata alist in "constructorKind"))) - (setf (database-constructorcategory dbstruct) + (setf (|dbCategory| dbstruct) (fetchdata alist in "constructorCategory")) (setf (database-documentation dbstruct) (fetchdata alist in "documentation")) - (setf (database-attributes dbstruct) + (setf (|dbAttributes| dbstruct) (fetchdata alist in "attributes")) - (setf (database-predicates dbstruct) + (setf (|dbPredicates| dbstruct) (fetchdata alist in "predicates")) (setf (|dbSuperDomain| dbstruct) (fetchdata alist in "superDomain")) (addoperations key oldmaps) (unless make-database? (if (eq kind '|category|) - (setf (database-ancestors dbstruct) + (setf (|dbAncestors| dbstruct) (|applySubst| (|pairList| (cdr constructorform) |$FormalMapVariableList|) @@ -1092,7 +1126,7 @@ (|updateCategoryTable| key kind) (if |$InteractiveMode| (setq |$CategoryFrame| |$EmptyEnvironment|))) - (setf (database-cosig dbstruct) + (setf (|dbDualSignature| dbstruct) (cons nil (mapcar #'|categoryForm?| (cddar (|dbConstructorModemap| dbstruct))))) (remprop key 'loaded) @@ -1192,7 +1226,7 @@ (dolist (con (|allConstructors|)) (let (dbstruct) (when (setq dbstruct (|constructorDB| con)) - (setf (database-cosig dbstruct) + (setf (|dbDualSignature| dbstruct) (cons nil (mapcar #'|categoryForm?| (cddar (|dbConstructorModemap| dbstruct))))) (when (and (|categoryForm?| con) @@ -1200,7 +1234,7 @@ (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))))))) + (setf (|dbDefaultDomain| dbstruct) (car d))))))) ; note: genCategoryTable creates *ancestors-hash*. write-interpdb ; does gethash calls into it rather than doing a getdatabase call. (write-interpdb) @@ -1296,9 +1330,9 @@ (print (squeeze (|dbConstructorModemap| struct)) out) (finish-output out) (setq modemapspos (file-position out)) - (print (squeeze (database-modemaps struct)) out) + (print (squeeze (|dbModemaps| struct)) out) (finish-output out) - (let ((entry (database-object struct))) + (let ((entry (|dbModule| struct))) (cond ((consp entry) (setq obj (cons (pathname-name (car entry)) (cdr entry)))) @@ -1306,7 +1340,7 @@ (setq obj (pathname-name (first (last (pathname-directory entry)))))) (t (setq obj nil)))) - (setq concategory (squeeze (database-constructorcategory struct))) + (setq concategory (squeeze (|dbCategory| struct))) (if concategory ; if category then write data else write nil (progn (setq categorypos (file-position out)) @@ -1314,9 +1348,9 @@ (finish-output out)) (setq categorypos nil)) (setq abbrev (|dbAbbreviation| struct)) - (setq cosig (database-cosig struct)) + (setq cosig (|dbDualSignature| struct)) (setq kind (|dbConstructorKind| struct)) - (setq defaultdomain (database-defaultdomain struct)) + (setq defaultdomain (|dbDefaultDomain| struct)) (setq ancestors (squeeze (gethash constructor *ancestors-hash*))) ;cattable.boot (if ancestors (progn @@ -1364,10 +1398,10 @@ (print (database-documentation struct) out) (finish-output out) (setq attpos (file-position out)) - (print (squeeze (database-attributes struct)) out) + (print (squeeze (|dbAttributes| struct)) out) (finish-output out) (setq predpos (file-position out)) - (print (squeeze (database-predicates struct)) out) + (print (squeeze (|dbPredicates| struct)) out) (finish-output out) (push (list constructor src formpos docpos attpos predpos) master))) (finish-output out) diff --git a/src/interp/database.boot b/src/interp/database.boot index 58abfb6b..7f6849a3 100644 --- a/src/interp/database.boot +++ b/src/interp/database.boot @@ -782,3 +782,18 @@ squeezeAll: %List %Code -> %List %Code squeezeAll x == [SQUEEZE t for t in x] +makeInitialDB [form,kind,abbrev,srcfile] == + db := makeDB form.op + dbConstructorForm(db) := form + dbConstructorKind(db) := kind + dbAbbreviation(db) := abbrev + property(abbrev,'ABBREVIATIONFOR) := form.op + dbSourceFile(db) := srcfile + setAutoLoadProperty form.op + +populateDBFromFile path == + try + dbfile := inputTextFile path + while (entry := readExpr dbfile) ~= %nothing repeat + makeInitialDB entry + finally closeStream dbfile diff --git a/src/interp/g-cndata.boot b/src/interp/g-cndata.boot index 70f40c52..ccf402ce 100644 --- a/src/interp/g-cndata.boot +++ b/src/interp/g-cndata.boot @@ -41,6 +41,8 @@ namespace BOOT --======================================================================= -- Build Table of Lower Case Constructor Names --======================================================================= +$lowerCaseConTb := nil + mkLowerCaseConTable() == --Called at system build time by function BUILD-INTERPSYS (see util.lisp) --Table is referenced by functions conPageFastPath and grepForAbbrev @@ -119,11 +121,11 @@ abbQuery(x) == sayKeyedMsg("S2IZ0003",[x]) installConstructor(cname,type) == + $lowerCaseConTb = nil => nil (entry := getCDTEntry(cname,true)) => entry item := [cname,getConstructorAbbreviationFromDB cname,nil] - if $lowerCaseConTb then - tableValue($lowerCaseConTb,cname) := item - tableValue($lowerCaseConTb,DOWNCASE cname) := item + tableValue($lowerCaseConTb,cname) := item + tableValue($lowerCaseConTb,DOWNCASE cname) := item constructorNameConflict(name,kind) == userError diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot index 8c61cf97..eab3bbec 100644 --- a/src/interp/spad-parser.boot +++ b/src/interp/spad-parser.boot @@ -1,4 +1,4 @@ --- Copyright (C) 2007-2009, Gabriel Dos Reis. +-- Copyright (C) 2007-2011, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -61,8 +61,7 @@ parseSpadFile sourceFile == -- we need to tell the post-parsing transformers that we're compiling -- Spad because few parse forms have slightly different representations -- depending on whether we are interpreter mode or compiler mode. - savedInteractiveMode := $InteractiveMode - $InteractiveMode := false + $InteractiveMode: local := false INIT_-BOOT_/SPAD_-READER() -- we need to restore the global input stream state after we -- finished messing with it. @@ -71,7 +70,6 @@ parseSpadFile sourceFile == -- If soureFile cannot be processed for whatever reasons -- get out of here instead of being stuck later. not (IN_-STREAM := MAKE_-INSTREAM sourceFile) => - $InteractiveMode := savedInteractiveMode IN_-STREAM := savedInStream systemError '"cannot open input source file" INITIALIZE_-PREPARSE IN_-STREAM @@ -81,13 +79,12 @@ parseSpadFile sourceFile == while not (_*EOF_* or FILE_-CLOSED) repeat BOOT_-LINE_-STACK : local := PREPARSE IN_-STREAM LINE : local := CDAR BOOT_-LINE_-STACK - PARSE_-NewExpr() + CATCH('SPAD__READER,PARSE_-NewExpr()) asts := [parseTransform postTransform POP_-STACK_-1(), :asts] -- clean up the mess, and get out of here IOCLEAR(IN_-STREAM, OUT_-STREAM) SHUT IN_-STREAM IN_-STREAM := savedInStream - $InteractiveMode := savedInteractiveMode -- we accumulated the parse trees in reverse order reverse! asts diff --git a/src/interp/sys-driver.boot b/src/interp/sys-driver.boot index f101bf6d..e2116f08 100644 --- a/src/interp/sys-driver.boot +++ b/src/interp/sys-driver.boot @@ -174,6 +174,12 @@ restart() == --% +initializeDatabases firstTime? == + initdb := getOptionValue "initial-db" => populateDBFromFile initdb + not firstTime? => openDatabases() + fillDatabasesInCore() + mkLowerCaseConTable() + ++ Initialize all global states that need to. Sub-routine of the command ++ line compiler, the script executor, etc. Mess with care. initializeGlobalState() == @@ -211,11 +217,7 @@ initializeGlobalState() == -- 3. Databases if $verbose and $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"database"]) - if init? then - fillDatabasesInCore() - mkLowerCaseConTable() - else - openDatabases() + initializeDatabases init? -- 4. Constructors if $verbose and $displayStartMsgs then |