aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/c-util.boot7
-rw-r--r--src/interp/daase.lisp12
-rw-r--r--src/interp/database.boot84
-rw-r--r--src/interp/i-funsel.boot5
-rw-r--r--src/interp/i-special.boot3
-rw-r--r--src/interp/lisplib.boot7
-rw-r--r--src/interp/spad-parser.boot6
-rw-r--r--src/interp/sys-driver.boot8
8 files changed, 77 insertions, 55 deletions
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index cd030a21..3c8bee94 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -53,6 +53,7 @@ module c_-util where
dbInfovec: %Symbol -> %Maybe %FunctorData
makeDefaultPackageParameters: %Database -> %List %Symbol
makeDefaultPackageAbbreviation: %Database -> %Symbol
+ completeDefaultPackageParameters: %List %Symbol -> %List %Symbol
--% Accessors of domain and category objects
@@ -237,11 +238,13 @@ $SetCategory ==
--%
-makeDefaultPackageParameters db ==
- parms := dbConstructorForm(db).args
+completeDefaultPackageParameters parms ==
dollar := first setDifference('(S A B C D E F G H I),parms)
[dollar,:parms]
+makeDefaultPackageParameters db ==
+ completeDefaultPackageParameters dbConstructorForm(db).args
+
makeDefaultPackageAbbreviation db ==
makeSymbol strconc(symbolName dbAbbreviation db,'"-")
diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp
index ed761760..3e799091 100644
--- a/src/interp/daase.lisp
+++ b/src/interp/daase.lisp
@@ -640,18 +640,10 @@
(operation
(setq stream *operation-stream*)
(setq data (gethash constructor *operation-hash*)))
- (constructormodemap
- (setq stream *interp-stream*)
- (when struct
- (setq data (|dbConstructorModemap| struct))))
(constructorcategory
(setq stream *interp-stream*)
(when struct
(setq data (|dbCategory| struct))))
- (operationalist
- (setq stream *interp-stream*)
- (when struct
- (setq data (|dbOperations| struct))))
(modemaps
(setq stream *interp-stream*)
(when struct
@@ -712,12 +704,8 @@
(setf (gethash constructor *operation-hash*) data))
(hascategory
(setf (gethash constructor |$HasCategoryTable|) data))
- (constructormodemap
- (setf (|dbConstructorModemap| struct) data))
(constructorcategory
(setf (|dbCategory| struct) data))
- (operationalist
- (setf (|dbOperations| struct) data))
(modemaps
(setf (|dbModemaps| struct) data))
(object
diff --git a/src/interp/database.boot b/src/interp/database.boot
index 863def62..423cf547 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -106,8 +106,10 @@ getConstructorAncestorsFromDB ctor ==
++ of the constructor `form'.
getConstructorModemap: %Symbol -> %Mode
getConstructorModemap ctor ==
- mm := GETDATABASE(ctor, 'CONSTRUCTORMODEMAP) => mm
- dbConstructorModemap loadDBIfNecessary constructorDB ctor
+ db := constructorDB ctor
+ if not dbBeingDefined? db and dbConstructorModemap db isnt [.,:.] then
+ loadDBIfNecessary db
+ dbConstructorModemap db
getConstructorFormFromDB: %Symbol -> %Form
getConstructorFormFromDB ctor ==
@@ -135,7 +137,10 @@ getConstructorDocumentationFromDB ctor ==
getConstructorOperationsFromDB: %Symbol -> %List %List %Form
getConstructorOperationsFromDB ctor ==
- GETDATABASE(ctor,"OPERATIONALIST")
+ db := constructorDB ctor
+ if not dbBeingDefined? db and dbOperations db isnt [.,:.] then
+ loadDBIfNecessary db
+ dbOperations db
getConstructorFullNameFromDB: %Symbol -> %Symbol
getConstructorFullNameFromDB ctor ==
@@ -166,6 +171,7 @@ getConstructorParentsFromDB ctor ==
getSuperDomainFromDB: %Symbol -> %Form
getSuperDomainFromDB ctor ==
+ builtinConstructor? ctor => nil
db := constructorDB ctor
if not dbBeingDefined? db then
loadDBIfNecessary db
@@ -811,33 +817,51 @@ makeInitialDB [form,kind,abbrev,srcfile] ==
dbSourceFile(db) := srcfile
setAutoLoadProperty form.op
-makeDefaultPackageForm db ==
- [makeDefaultPackageName symbolName dbConstructor db,
- :makeDefaultPackageParameters db]
-
-printInitdbInfo(path,dbfile) == main(path,dbfile) where
- main(path,dbfile) ==
- for x in parseSpadFile path repeat
- x is ['DEF,lhs,.,rhs] =>
- fn(lhs,rhs,fileNameString path,dbfile)
- x is ["where",['DEF,lhs,.,rhs],:.] =>
- fn(lhs,rhs,fileNameString path,dbfile)
- fn(lhs,rhs,path,dbfile) ==
- if lhs isnt [.,:.] then lhs := [lhs]
- db := constructorDB lhs.op
- db = nil => nil
- args := [id for x in lhs.args]
- where id() == (x is [":",x',:.] => x'; x)
- data := [[lhs.op,:args],dbConstructorKind db,dbAbbreviation db,path]
- prettyPrint(['makeInitialDB,quote data],dbfile)
- writeNewline dbfile
- -- If this is a category with defaults, write out the data for
- -- associated package.
- dbConstructorKind db isnt 'category or rhs isnt ['add,:.] => nil
- data := [makeDefaultPackageForm db,'package,
- makeDefaultPackageAbbreviation db,path]
- prettyPrint(['makeInitialDB,quote data],dbfile)
- writeNewline dbfile
+defaultPackageForm lhs ==
+ [makeDefaultPackageName symbolName lhs.op,
+ :completeDefaultPackageParameters lhs.args]
+
+++ If `decl` is a simple macro definition for `x, return
+++ the definiens. Otherwise, return nil.
+simpleMacro?(x,decl) ==
+ not ident? x => nil
+ decl is ['MDEF,=x,=nil,body] => body
+ decl is ['DEF,[=x],[=nil],body] => body
+ nil
+
+++ If `x` is defined as a simple macro in `decl`, return the body
+++ of that definition.
+macroDefined?(x,decl) ==
+ decl is ['SEQ,:stmts,['exit,.,val]] =>
+ or/[body for stmt in stmts | body := simpleMacro?(x,stmt)]
+ or simpleMacro?(x,val)
+ simpleMacro?(x,decl)
+
+writeMinimalDB(lhs,rhs,path,dbfile) ==
+ if lhs isnt [.,:.] then lhs := [lhs]
+ db := constructorDB lhs.op
+ db = nil => nil
+ args := [id for x in lhs.args]
+ where id() == (x is [":",x',:.] => x'; x)
+ data := [[lhs.op,:args],dbConstructorKind db,dbAbbreviation db,path]
+ prettyPrint(['makeInitialDB,quote data],dbfile)
+ writeNewline dbfile
+ -- If this is a category with defaults, write out the data for
+ -- associated package.
+ dbConstructorKind db isnt 'category or rhs isnt ['add,:.] => nil
+ data := [defaultPackageForm lhs,'package,
+ makeDefaultPackageAbbreviation db,path]
+ prettyPrint(['makeInitialDB,quote data],dbfile)
+ writeNewline dbfile
+
+printInitdbInfo(path,dbfile) ==
+ for x in parseSpadFile path repeat
+ x is ['DEF,lhs,.,rhs] =>
+ writeMinimalDB(lhs,rhs,fileNameString path,dbfile)
+ x is ["where",['DEF,lhs,.,rhs],decl] =>
+ if ident? rhs and (body := macroDefined?(rhs,decl)) then
+ rhs := body
+ writeMinimalDB(lhs,rhs,fileNameString path,dbfile)
printAllInitdbInfo(srcdir,dbfile) ==
paths := DIRECTORY strconc(ensureTrailingSlash srcdir,'"*.spad")
diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot
index 4d1675e7..7c2bf3df 100644
--- a/src/interp/i-funsel.boot
+++ b/src/interp/i-funsel.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2012, Gabriel Dos Reis.
+-- Copyright (C) 2007-2016, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -690,6 +690,7 @@ getFunctionFromDomain(op,dc,args) ==
isOpInDomain(opName,dom,nargs) ==
-- returns true only if there is an op in the given domain with
-- the given number of arguments
+ builtinFunctorName? dom.op => nil -- FIXME
mmList := objectAssoc(opName,getConstructorOperationsFromDB dom.op)
mmList := subCopy(mmList,constructSubst dom)
mmList = nil => nil
@@ -720,6 +721,7 @@ findCommonSigInDomain(opName,dom,nargs) ==
findUniqueOpInDomain(op,opName,dom) ==
-- return function named op in domain dom if unique, choose one if not
+ builtinFunctorName? dom.op => nil -- FIXME
mmList := objectAssoc(opName,getConstructorOperationsFromDB dom.op)
mmList := subCopy(mmList,constructSubst dom)
mmList = nil =>
@@ -1613,6 +1615,7 @@ hasSig(dom,foo,sig,SL) ==
-- under substitution SL
$domPvar: local := nil
fun:= getConstructorAbbreviationFromDB dom.op =>
+ builtinFunctorName? dom.op => nil -- FIXME
S0:= constructSubst dom
p := objectAssoc(foo,getConstructorOperationsFromDB dom.op) =>
for [x,.,cond,.] in rest p until S isnt 'failed repeat
diff --git a/src/interp/i-special.boot b/src/interp/i-special.boot
index eb9f984d..17d3d275 100644
--- a/src/interp/i-special.boot
+++ b/src/interp/i-special.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2012, Gabriel Dos Reis.
+-- Copyright (C) 2007-2016, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -1331,6 +1331,7 @@ upDEF t ==
++ <%Mode>: the type of the constant.
++ T: too many constants designated by `form'.
constantInDomain?(form,domainForm) ==
+ builtinFunctorName? domainForm.op => nil
opAlist := getConstructorOperationsFromDB domainForm.op
key := opOf form
entryList := [entry for (entry := [.,.,.,k]) in LASSOC(key,opAlist)
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 2d02af64..a47ed36c 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2015, Gabriel Dos Reis.
+-- Copyright (C) 2007-2016, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -754,8 +754,9 @@ isFunctor x ==
getConstructorKindFromDB op in '(domain package)
u := get(op,'isFunctor,$CategoryFrame) => u
builtinFunctorName? op => true
- kind := getConstructorKindFromDB op
- kind = nil or kind = 'category => false
+ db := constructorDB op or return false
+ dbConstructorKind db = 'category => false
+ loadDBIfNecessary db
updateCategoryFrameForConstructor op
get(op,'isFunctor,$CategoryFrame)
diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot
index 028a30b9..7e196d10 100644
--- a/src/interp/spad-parser.boot
+++ b/src/interp/spad-parser.boot
@@ -1,4 +1,4 @@
--- Copyright (C) 2007-2014, Gabriel Dos Reis.
+-- Copyright (C) 2007-2016, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -91,6 +91,10 @@ indentationLocation line ==
tabChar? line.i => loc := 8 * (loc quo 8 + 1)
return loc
+storeBlanks!(line,n) ==
+ #line >= n => nil
+ stringChar(line,n) := char " "
+
skipIfBlock rs ==
[n,:line] := z := preparseReadLine1 rs
not string? line => z
diff --git a/src/interp/sys-driver.boot b/src/interp/sys-driver.boot
index 5abf11fd..010a6bab 100644
--- a/src/interp/sys-driver.boot
+++ b/src/interp/sys-driver.boot
@@ -1,4 +1,4 @@
--- Copyright (C) 2007-2014 Gabriel Dos Reis
+-- Copyright (C) 2007-2016 Gabriel Dos Reis
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -174,10 +174,8 @@ restart() ==
initializeDatabases firstTime? ==
getOptionValue "build-initdb" => nil
- --initdb := getOptionValue "initial-db" => LOAD initdb
- --FIXME: Ideally we should execute the previous line. The next line is
- --FIXME: a short-term stopgap until build dependencies are in place.
- if initdb := getOptionValue "initial-db" then
+ initdb := getOptionValue "initial-db" =>
+ CATEGORYOPEN()
LOAD initdb
not firstTime? => openDatabases()
fillDatabasesInCore()
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-23 05:49:37 +0000