aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/ChangeLog28
-rw-r--r--src/interp/Makefile.in6
-rw-r--r--src/interp/br-op1.boot2
-rw-r--r--src/interp/daase.lisp82
-rw-r--r--src/interp/database.boot2
-rw-r--r--src/interp/define.boot36
-rw-r--r--src/interp/lisplib.boot40
-rw-r--r--src/interp/nlib.lisp1
-rw-r--r--src/interp/patches.lisp44
-rw-r--r--src/interp/sys-constants.boot5
-rw-r--r--src/interp/sys-utility.boot5
-rw-r--r--src/share/algebra/browse.daase2
-rw-r--r--src/share/algebra/category.daase2
-rw-r--r--src/share/algebra/compress.daase2
-rw-r--r--src/share/algebra/interp.daase2
-rw-r--r--src/share/algebra/operation.daase2
-rw-r--r--src/utils/storage.H76
17 files changed, 191 insertions, 146 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 76d2390c..c8b836a1 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,26 @@
+2011-08-20 Gabriel Dos Reis <gdr@cse.tamu.edu>
+
+ * interp/sys-utility.boot (constructorDB): New.
+ * interp/daase.lisp (dbNiladic?): New. Use it to access niladic
+ property. of a constructor.
+ * interp/database.boot: Import daase.
+ (niladicContructorFromDB): Use it.
+ * interp/define.boot (compDefineCategory): Don't write
+ compilerInfo garbage.
+ (compDefineFunctor1): Likewise.
+ (compDefineCategory2): Set niladic property.
+ (compDefineFunctor): Likewise.
+ * interp/lisplib.boot (loadLib): Do not set niladic property. It
+ is now a side-effect of loading.
+ (loadLibNoUpdate): Do not check for version.
+ (makeConstructorAutoload): Do not set niladic property.
+ (initializeLisplib): Do not emit code to check version.
+ (mkCtorDBForm): New.
+ (writeNiladic?): Likewise.
+ (finalizeLisplib): Do not set niladic property.
+ * interp/patches.lisp: Remove deadcode.
+ * interp/sys-constants.boot (MAJOR-VERSION): Remove.
+
2011-08-20 Gabriel Dos Reis <gdr@cs.tamu.edu>
* algebra/polycat.spad.pamphlet (UnivariatePolynomialCategory)
@@ -504,6 +527,11 @@
2011-06-26 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * utils/storage.H (Memory::Arena): Extend.
+ (Memory::Factory): Add iterators. Make bidirectional.
+
+2011-06-26 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* algebra/sf.spad.pamphlet (DoubleFloat) [nan?]: New export.
* algebra/clip.spad.pamphlet (TwoDimensionalPlotClipping): Use it
instead of %fNan?.
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 548a104f..5c10c62d 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -70,7 +70,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \
cattable.$(FASLEXT) posit.$(FASLEXT) \
cformat.$(FASLEXT) clam.$(FASLEXT) \
clammed.$(FASLEXT) nlib.$(FASLEXT) \
- comp.$(FASLEXT) \
+ comp.$(FASLEXT) daase.$(FASLEXT) \
pathname.$(FASLEXT) compat.$(FASLEXT) \
serror.$(FASLEXT) ptrees.$(FASLEXT) \
cparse.$(FASLEXT) cstream.$(FASLEXT) \
@@ -103,7 +103,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \
preparse.$(FASLEXT) bootlex.$(FASLEXT) \
spad.$(FASLEXT) spaderror.$(FASLEXT) \
termrw.$(FASLEXT) \
- trace.$(FASLEXT) daase.$(FASLEXT) \
+ trace.$(FASLEXT) \
fortcall.$(FASLEXT) i-parser.$(FASLEXT) \
$(OCOBJS) $(BROBJS) $(INOBJS)
@@ -305,7 +305,7 @@ nrunfast.$(FASLEXT): c-util.$(FASLEXT)
nruncomp.$(FASLEXT): profile.$(FASLEXT) simpbool.$(FASLEXT) functor.$(FASLEXT)
nrungo.$(FASLEXT): c-util.$(FASLEXT) clam.$(FASLEXT) interop.$(FASLEXT)
define.$(FASLEXT): g-error.$(FASLEXT) nruncomp.$(FASLEXT) database.$(FASLEXT)
-database.$(FASLEXT): clam.$(FASLEXT) nlib.$(FASLEXT) \
+database.$(FASLEXT): clam.$(FASLEXT) nlib.$(FASLEXT) daase.$(FASLEXT) \
cattable.$(FASLEXT) compat.$(FASLEXT) g-cndata.$(FASLEXT) \
c-util.$(FASLEXT)
functor.$(FASLEXT): category.$(FASLEXT) interop.$(FASLEXT) lisplib.$(FASLEXT)
diff --git a/src/interp/br-op1.boot b/src/interp/br-op1.boot
index a7c1efa4..ce3b40a0 100644
--- a/src/interp/br-op1.boot
+++ b/src/interp/br-op1.boot
@@ -920,7 +920,7 @@ mathform2HtString form == escapeString
niladicHack form ==
form isnt [.,:.] => form
- form is [x] and GETL(x,"NILADIC") => x
+ form is [x] and niladicConstructorFromDB x => x
[niladicHack x for x in form]
--============================================================================
diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp
index ad849541..07d90cfc 100644
--- a/src/interp/daase.lisp
+++ b/src/interp/daase.lisp
@@ -229,6 +229,10 @@
spare ; superstition
) ; database structure
+
+(defmacro |dbNiladic?| (db)
+ `(database-niladic ,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.
@@ -572,13 +576,13 @@
(setq item (unsqueeze item))
(setq *allconstructors* (adjoin (first item) *allconstructors*))
(setq dbstruct (make-database))
- (setf (get (car item) 'database) dbstruct)
+ (setf (|constructorDB| (car item)) 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 (|dbNiladic?| dbstruct) (seventh item))
(setf (database-abbreviation dbstruct) (eighth item))
(setf (get (eighth item) 'abbreviationfor) (first item)) ;invert
(setf (database-cosig dbstruct) (ninth item))
@@ -629,13 +633,13 @@
(setq constructors (read *browse-stream*))
(dolist (item constructors)
(setq item (unsqueeze item))
- (unless (setq dbstruct (get (car item) 'database))
+ (unless (setq dbstruct (|constructorDB| (car item)))
(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)))
+ (setf (|constructorDB| (car item)) (setq dbstruct (make-database)))
(setq *allconstructors* (adjoin item *allconstructors*)))
(setf (database-sourcefile dbstruct) (second item))
(setf (database-constructorform dbstruct) (third item))
@@ -744,9 +748,9 @@
(defun setdatabase (constructor key value)
(let (struct)
(when (symbolp constructor)
- (unless (setq struct (get constructor 'database))
+ (unless (setq struct (|constructorDB| constructor))
(setq struct (make-database))
- (setf (get constructor 'database) struct))
+ (setf (|constructorDB| constructor) struct))
(case key
(abbreviation
(setf (database-abbreviation struct) value)
@@ -776,36 +780,36 @@
; thus they occur first in the list of things to check
(abbreviation
(setq stream *interp-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-abbreviation struct))))
(constructorkind
(setq stream *interp-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-constructorkind struct))))
(cosig
(setq stream *interp-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(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))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-constructormodemap struct))))
(constructorcategory
(setq stream *interp-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-constructorcategory struct))
(when (null data) ;domain or package then subfield of constructormodemap
(setq data (cadar (|getConstructorModemapFromDB| constructor))))))
(operationalist
(setq stream *interp-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-operationalist struct))))
(modemaps
(setq stream *interp-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-modemaps struct))))
(hascategory
(setq table *hasCategory-hash*)
@@ -813,17 +817,17 @@
(setq data (gethash constructor table)))
(object
(setq stream *interp-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-object struct))))
(niladic
(setq stream *interp-stream*)
- (when (setq struct (get constructor 'database))
- (setq data (database-niladic struct))))
+ (when (setq struct (|constructorDB| constructor))
+ (setq data (|dbNiladic?| struct))))
(constructor?
(|fatalError| "GETDATABASE called with CONSTRUCTOR?"))
(superdomain ; only 2 superdomains in the world
(setq stream *interp-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-superdomain struct))))
(constructor
(when (setq data (get constructor 'abbreviationfor))))
@@ -831,41 +835,41 @@
(setq data (cadr (assoc constructor *defaultdomain-list*))))
(ancestors
(setq stream *interp-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-ancestors struct))))
(sourcefile
(setq stream *browse-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-sourcefile struct))))
(constructorform
(setq stream *browse-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-constructorform struct))))
(constructorargs
(setq data (cdr (|getConstructorFormFromDB| constructor))))
(attributes
(setq stream *browse-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-attributes struct))))
(predicates
(setq stream *browse-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-predicates struct))))
(documentation
(setq stream *browse-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-documentation struct))))
(parents
(setq stream *browse-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-parents struct))))
(users
(setq stream *browse-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-users struct))))
(dependents
(setq stream *browse-stream*)
- (when (setq struct (get constructor 'database))
+ (when (setq struct (|constructorDB| constructor))
(setq data (database-dependents struct))))
(otherwise
(warn "~%(GETDATABASE ~a ~a) failed~%" constructor key)))
@@ -898,7 +902,7 @@
(object
(setf (database-object struct) data))
(niladic
- (setf (database-niladic struct) data))
+ (setf (|dbNiladic?| struct) data))
(abbreviation
(setf (database-abbreviation struct) data))
(constructor
@@ -1039,7 +1043,7 @@
(setq oldmaps (|getOperationModemapsFromDB| key))
(setq dbstruct (make-database))
(setq *allconstructors* (adjoin key *allconstructors*))
- (setf (get key 'database) dbstruct) ; store the struct, side-effect it...
+ (setf (|constructorDB| key) dbstruct) ; store the struct, side-effect it...
(setf (database-constructorform dbstruct) constructorform)
(setq *allOperations* nil) ; force this to recompute
(setf (database-object dbstruct) object)
@@ -1069,7 +1073,7 @@
(fetchdata alist in "attributes"))
(setf (database-predicates dbstruct)
(fetchdata alist in "predicates"))
- (setf (database-niladic dbstruct)
+ (setf (|dbNiladic?| dbstruct)
(when (fetchdata alist in "NILADIC") t))
(let ((super (fetchdata alist in "evalOnLoad2")))
(setf (database-superdomain dbstruct)
@@ -1133,19 +1137,19 @@
(withSpecialConstructors ()
; note: if item is not in *operationalist-hash* it will not be written
; UNION
- (setf (get '|Union| 'database)
+ (setf (|constructorDB| '|Union|)
(make-database :operationalist nil :constructorkind '|domain|))
(push '|Union| *allconstructors*)
; RECORD
- (setf (get '|Record| 'database)
+ (setf (|constructorDB| '|Record|)
(make-database :operationalist nil :constructorkind '|domain|))
(push '|Record| *allconstructors*)
; MAPPING
- (setf (get '|Mapping| 'database)
+ (setf (|constructorDB| '|Mapping|)
(make-database :operationalist nil :constructorkind '|domain|))
(push '|Mapping| *allconstructors*)
; ENUMERATION
- (setf (get '|Enumeration| 'database)
+ (setf (|constructorDB| '|Enumeration|)
(make-database :operationalist nil :constructorkind '|domain|))
(push '|Enumeration| *allconstructors*)
)
@@ -1155,8 +1159,8 @@
(let (d)
(declare (special |$constructorList|))
(do-symbols (symbol)
- (when (get symbol 'database)
- (setf (get symbol 'database) nil)))
+ (when (|constructorDB| symbol)
+ (setf (|constructorDB| symbol) nil)))
(setq *hascategory-hash* (make-hash-table :test #'equal))
(setq *operation-hash* (make-hash-table))
(setq *allconstructors* nil)
@@ -1191,7 +1195,7 @@
(write-categorydb)
(dolist (con (|allConstructors|))
(let (dbstruct)
- (when (setq dbstruct (get con 'database))
+ (when (setq dbstruct (|constructorDB| con))
(setf (database-cosig dbstruct)
(cons nil (mapcar #'|categoryForm?|
(cddar (database-constructormodemap dbstruct)))))
@@ -1288,7 +1292,7 @@
(finish-output out)
(dolist (constructor (|allConstructors|))
(let (struct)
- (setq struct (get constructor 'database))
+ (setq struct (|constructorDB| constructor))
(setq opalistpos (file-position out))
(print (squeeze (database-operationalist struct)) out)
(finish-output out)
@@ -1313,7 +1317,7 @@
(print concategory out)
(finish-output out))
(setq categorypos nil))
- (setq niladic (database-niladic struct))
+ (setq niladic (|dbNiladic?| struct))
(setq abbrev (database-abbreviation struct))
(setq cosig (database-cosig struct))
(setq kind (database-constructorkind struct))
@@ -1355,7 +1359,7 @@
(finish-output out)
(dolist (constructor (|allConstructors|))
(let (struct)
- (setq struct (get constructor 'database))
+ (setq struct (|constructorDB| constructor))
; sourcefile is small. store the string directly
(setq src (database-sourcefile struct))
(setq formpos (file-position out))
diff --git a/src/interp/database.boot b/src/interp/database.boot
index 72cb5fc7..0bd98389 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -38,6 +38,7 @@ import c_-util
import clam
import cattable
import compat
+import daase
namespace BOOT
$getUnexposedOperations := true
@@ -132,6 +133,7 @@ getConstructorAttributesFromDB ctor ==
niladicConstructorFromDB: %Constructor -> %Boolean
niladicConstructorFromDB ctor ==
+ property(ctor,'LOADED) => dbNiladic? constructorDB ctor
GETDATABASE(ctor,"NILADIC")
constructorHasCategoryFromDB: %Pair(%Thing,%Thing) -> %List %Code
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 67802fc4..876d57e9 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1047,16 +1047,8 @@ compDefineCategory2(form,signature,specialCases,body,m,e,
-- If we are only interested in the defaults, there is no point
-- in writing out compiler info and load-time stuff for
-- the category which is assumed to have already been translated.
- if not $compileDefaultsOnly then
- lisplibWrite('"compilerInfo",
- removeZeroOne ['SETQ,'$CategoryFrame,
- ['put,['QUOTE,op'],'
- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm,
- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile)
- --Equivalent to the following two lines, we hope
- if null sargl then
- evalAndRwriteLispForm('NILADIC,
- ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true])
+ if not $compileDefaultsOnly and null sargl then
+ writeNiladic?(op',$libFile)
-- 6. put modemaps into InteractiveModemapFrame
$domainShell := eval [op',:[MKQ f for f in sargl]]
@@ -1085,11 +1077,13 @@ compDefineCategory(df,m,e,prefix,fal) ==
$lisplibCategory: local := nil
-- since we have so many ways to say state the kind of a constructor,
-- make sure we do have some minimal internal coherence.
- ctor := opOf second df
+ lhs := second df
+ ctor := opOf lhs
kind := getConstructorKindFromDB ctor
kind ~= "category" => throwKeyedMsg("S2IC0016",[ctor,"category",kind])
- $insideFunctorIfTrue or not $LISPLIB or $compileDefaultsOnly =>
+ $insideFunctorIfTrue or $LISPLIB = nil or $compileDefaultsOnly =>
compDefineCategory1(df,m,e,prefix,fal)
+ dbNiladic?(constructorDB ctor) := lhs isnt [.,:.] or lhs.args = nil
compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1)
@@ -1345,8 +1339,11 @@ compDefineFunctor(df,m,e,prefix,fal) ==
$profileCompiler: local := true
$profileAlist: local := nil
$mutableDomain: local := false
- $compileExportsOnly or not $LISPLIB =>
+ $compileExportsOnly or $LISPLIB = nil =>
compDefineFunctor1(df,m,e,prefix,fal)
+ lhs := second df
+ ctor := opOf lhs
+ dbNiladic?(constructorDB ctor) := lhs isnt [.,:.] or lhs.args = nil
compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1)
compDefineFunctor1(df is ['DEF,form,signature,nils,body],
@@ -1476,21 +1473,12 @@ compDefineFunctor1(df is ['DEF,form,signature,nils,body],
$byteVec :local := nil
$NRTslot1PredicateList :=
[simpBool x for x in $NRTslot1PredicateList]
- rwriteLispForm('loadTimeStuff,
+ LAM_,FILEACTQ('loadTimeStuff,
['MAKEPROP,MKQ $op,''infovec,getInfovecCode()])
$lisplibSlot1 := $NRTslot1Info
$lisplibOperationAlist:= operationAlist
- lisplibWrite('"compilerInfo",
- removeZeroOne ['SETQ,'$CategoryFrame,
- ['put,['QUOTE,op'],'
- (QUOTE isFunctor),
- ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],['
- QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'],
- ['put,['QUOTE,op' ],'(QUOTE mode),
- ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]],$libFile)
if null argl then
- evalAndRwriteLispForm('NILADIC,
- ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true])
+ writeNiladic?(op',$libFile)
-- Functors are incomplete during bootstrap
if $bootStrapMode then
evalAndRwriteLispForm('%incomplete,
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index cc766b57..b0966204 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -326,12 +326,6 @@ loadLib cname ==
[[.,:sig],:.] := u
[nil,:[categoryForm?(x) for x in rest sig]]
nil
- -- in following, add property value false or nil to possibly clear
- -- old value
- if null rest getConstructorFormFromDB cname then
- property(cname,'NILADIC) := true
- else
- property(cname,'NILADIC) := nil
property(cname,'LOADED) := fullLibName
if $InteractiveMode then $CategoryFrame := $EmptyEnvironment
stopTimingProcess 'load
@@ -341,18 +335,12 @@ loadLibNoUpdate(cname, libName, fullLibName) ==
kind := getConstructorKindFromDB cname
if $printLoadMsgs then
sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname])
- if CATCH('VERSIONCHECK,loadModule(fullLibName,cname)) = -1
- then
- writeString('" wrong library version...recompile ")
- PRINC(fullLibName)
- TERPRI()
- TOPLEVEL()
- else
- clearConstructorCache cname
- installConstructor(cname,kind)
- property(cname,'LOADED) := fullLibName
- if $InteractiveMode then $CategoryFrame := $EmptyEnvironment
- stopTimingProcess 'load
+ loadModule(fullLibName,cname)
+ clearConstructorCache cname
+ installConstructor(cname,kind)
+ property(cname,'LOADED) := fullLibName
+ if $InteractiveMode then $CategoryFrame := $EmptyEnvironment
+ stopTimingProcess 'load
'T
loadIfNecessary u == loadLibIfNecessary(u,true)
@@ -406,10 +394,6 @@ makeConstructorsAutoLoad() ==
for cnam in allConstructors() repeat
builtinCategoryName? cnam => nil
property(cnam,'LOADED) := nil
--- fn:=getConstructorAbbreviationFromDB cnam
- if niladicConstructorFromDB cnam
- then property(cnam,'NILADIC) := 'T
- else property(cnam,'NILADIC) := nil
systemDependentMkAutoload(getConstructorAbbreviationFromDB cnam,cnam)
systemDependentMkAutoload(fn,cnam) ==
@@ -554,8 +538,14 @@ initializeLisplib libName ==
resetErrorCount()
$libFile := writeLib1(libName,'ERRORLIB,$libraryDirectory)
ADDOPTIONS('FILE,$libFile)
- if pathnameTypeId(_/EDITFILE) is 'SPAD
- then LAM_,FILEACTQ('VERSION,['_/VERSIONCHECK,_/MAJOR_-VERSION])
+
+mkCtorDBForm ctor ==
+ ['constructorDB,quoteForm ctor]
+
+writeNiladic?(ctor,file) ==
+ insn := ['%store,['dbNiladic?,mkCtorDBForm ctor],'%true]
+ LAM_,FILEACTQ('NILADIC,expandToVMForm insn)
+ lisplibWrite('"NILADIC",true,file)
++ If compilation produces an error, issue inform user and
++ return to toplevel reader.
@@ -597,8 +587,6 @@ finalizeLisplib libName ==
lisplibWrite('"documentation",finalizeDocumentation(),$libFile)
lisplibWrite('"slot1Info",removeZeroOne $lisplibSlot1,$libFile)
if $profileCompiler then profileWrite()
- if $lisplibForm and null rest $lisplibForm then
- property(first $lisplibForm,'NILADIC) := true
leaveIfErrors libName
true
diff --git a/src/interp/nlib.lisp b/src/interp/nlib.lisp
index 1f4f913e..4ee13797 100644
--- a/src/interp/nlib.lisp
+++ b/src/interp/nlib.lisp
@@ -107,6 +107,7 @@
(file-position stream pos))
(t (file-position stream 0)
(princ " " stream)
+ (terpri stream)
(setq indextable pos)))
(values stream indextable)))
diff --git a/src/interp/patches.lisp b/src/interp/patches.lisp
index e49d0e7b..68d17fc9 100644
--- a/src/interp/patches.lisp
+++ b/src/interp/patches.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2010, Gabriel Dos Reis.
+;; Copyright (C) 2007-2011, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -192,45 +192,3 @@
)
)
-#+:akcl
-(defun print-xdr-stream (x y z) (format y "XDR:~A" (xdr-stream-name x)))
-#+:akcl
-(defstruct (xdr-stream
- (:print-function print-xdr-stream))
- "A structure to hold XDR streams. The stream is printed out."
- (handle ) ;; this is what is used for xdr-open xdr-read xdr-write
- (name )) ;; this is used for printing
-#+(and :gcl (not (or :dos :win32)))
-(defun |xdrOpen| (str dir) (make-xdr-stream :handle (system:xdr-open str) :name str))
-#+(and :gcl (or :dos :win32))
-(defun |xdrOpen| (str dir) (format t "xdrOpen called"))
-
-#+(and :akcl (not (or :dos :win32)))
-(defun |xdrRead| (xstr r) (system:xdr-read (xdr-stream-handle xstr) r) )
-#+(and :gcl (or :dos :win32))
-(defun |xdrRead| (str) (format t "xdrRead called"))
-
-#+(and :akcl (not (or :dos :win32)))
-(defun |xdrWrite| (xstr d) (system:xdr-write (xdr-stream-handle xstr) d) )
-#+(and :gcl (or :dos :win32))
-(defun |xdrWrite| (str) (format t "xdrWrite called"))
-
-;; here is a test for XDR
-;; (setq *print-array* T)
-;; (setq foo (open "xdrtest" :direction :output))
-;; (setq xfoo (|xdrOpen| foo))
-;; (|xdrWrite| xfoo "hello: This contains an integer, a float and a float array")
-;; (|xdrWrite| xfoo 42)
-;; (|xdrWrite| xfoo 3.14159)
-;; (|xdrWrite| xfoo (make-array 10 :element-type 'long-float :initial-element 2.78111D12))
-;; (close foo)
-;; (setq foo (open "xdrtest" :direction :input))
-;; (setq xfoo (|xdrOpen| foo))
-;; (|xdrRead| xfoo "")
-;; (|xdrRead| xfoo 0)
-;; (|xdrRead| xfoo 0.0)
-;; (|xdrRead| xfoo (make-array 10 :element-type 'long-float ))
-;; (setq *print-array* NIL)
-
-(defun /versioncheck (n) (unless (= n /MAJOR-VERSION) (throw 'versioncheck -1)))
-
diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot
index 3812d378..bc2366ec 100644
--- a/src/interp/sys-constants.boot
+++ b/src/interp/sys-constants.boot
@@ -74,11 +74,6 @@ $DoubleFloatEpsilon ==
$timerTicksPerSecond ==
INTERNAL_-TIME_-UNITS_-PER_-SECOND
-
-++ Internal magic coockie.
-_/MAJOR_-VERSION ==
- 2
-
--
-- Text formatting
--
diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot
index 1b404d9b..c6859362 100644
--- a/src/interp/sys-utility.boot
+++ b/src/interp/sys-utility.boot
@@ -388,3 +388,8 @@ displayTextFile f ==
writeLine(line,$OutputStream)
finally
stream ~= nil => closeStream stream
+
+--%
+macro constructorDB ctor ==
+ property(ctor,'DATABASE)
+
diff --git a/src/share/algebra/browse.daase b/src/share/algebra/browse.daase
index df370548..c81fd57e 100644
--- a/src/share/algebra/browse.daase
+++ b/src/share/algebra/browse.daase
@@ -1,5 +1,5 @@
-(2276906 . 3522680061)
+(2276906 . 3522866252)
(-18 A S)
((|constructor| (NIL "One-dimensional-array aggregates serves as models for one-dimensional arrays. Categorically,{} these aggregates are finite linear aggregates with the \\spadatt{shallowlyMutable} property,{} that is,{} any component of the array may be changed without affecting the identity of the overall array. Array data structures are typically represented by a fixed area in storage and therefore cannot efficiently grow or shrink on demand as can list structures (see however \\spadtype{FlexibleArray} for a data structure which is a cross between a list and an array). Iteration over,{} and access to,{} elements of arrays is extremely fast (and often can be optimized to open-code). Insertion and deletion however is generally slow since an entirely new data structure must be created for the result.")))
NIL
diff --git a/src/share/algebra/category.daase b/src/share/algebra/category.daase
index 84a6fa93..f1b9711a 100644
--- a/src/share/algebra/category.daase
+++ b/src/share/algebra/category.daase
@@ -1,5 +1,5 @@
-(205500 . 3522680065)
+(205500 . 3522866257)
((((-877)) . T))
((((-877)) . T))
((((-877)) . T))
diff --git a/src/share/algebra/compress.daase b/src/share/algebra/compress.daase
index a15ed8f1..c49eeb83 100644
--- a/src/share/algebra/compress.daase
+++ b/src/share/algebra/compress.daase
@@ -1,5 +1,5 @@
-(30 . 3522680059)
+(30 . 3522866251)
(4428 |Enumeration| |Mapping| |Record| |Union| |ofCategory| |isDomain|
ATTRIBUTE |package| |domain| |category| CATEGORY |nobranch| AND |Join|
|ofType| SIGNATURE "failed" "algebra" |OneDimensionalArrayAggregate&|
diff --git a/src/share/algebra/interp.daase b/src/share/algebra/interp.daase
index d1c344d0..86317845 100644
--- a/src/share/algebra/interp.daase
+++ b/src/share/algebra/interp.daase
@@ -1,5 +1,5 @@
-(3432426 . 3522680074)
+(3432426 . 3522866267)
((-1935 (((-114) (-1 (-114) |#2| |#2|) $) 86 T ELT) (((-114) $) NIL T ELT)) (-1933 (($ (-1 (-114) |#2| |#2|) $) 18 T ELT) (($ $) NIL T ELT)) (-4218 ((|#2| $ (-558) |#2|) NIL T ELT) ((|#2| $ (-1255 (-558)) |#2|) 44 T ELT)) (-2510 (($ $) 80 T ELT)) (-4272 ((|#2| (-1 |#2| |#2| |#2|) $ |#2| |#2|) 52 T ELT) ((|#2| (-1 |#2| |#2| |#2|) $ |#2|) 50 T ELT) ((|#2| (-1 |#2| |#2| |#2|) $) 49 T ELT)) (-3839 (((-558) (-1 (-114) |#2|) $) 27 T ELT) (((-558) |#2| $) NIL T ELT) (((-558) |#2| $ (-558)) 96 T ELT)) (-3290 (((-661 |#2|) $) 13 T ELT)) (-3938 (($ (-1 (-114) |#2| |#2|) $ $) 64 T ELT) (($ $ $) NIL T ELT)) (-2160 (($ (-1 |#2| |#2|) $) 37 T ELT)) (-4388 (($ (-1 |#2| |#2|) $) NIL T ELT) (($ (-1 |#2| |#2| |#2|) $ $) 60 T ELT)) (-2517 (($ |#2| $ (-558)) NIL T ELT) (($ $ $ (-558)) 67 T ELT)) (-1468 (((-3 |#2| "failed") (-1 (-114) |#2|) $) 29 T ELT)) (-2158 (((-114) (-1 (-114) |#2|) $) 23 T ELT)) (-4230 ((|#2| $ (-558) |#2|) NIL T ELT) ((|#2| $ (-558)) NIL T ELT) (($ $ (-1255 (-558))) 66 T ELT)) (-2518 (($ $ (-558)) 76 T ELT) (($ $ (-1255 (-558))) 75 T ELT)) (-2157 (((-791) (-1 (-114) |#2|) $) 34 T ELT) (((-791) |#2| $) NIL T ELT)) (-1934 (($ $ $ (-558)) 69 T ELT)) (-3820 (($ $) 68 T ELT)) (-3950 (($ (-661 |#2|)) 73 T ELT)) (-4232 (($ $ |#2|) NIL T ELT) (($ |#2| $) NIL T ELT) (($ $ $) 87 T ELT) (($ (-661 $)) 85 T ELT)) (-4376 (((-877) $) 92 T ELT)) (-2159 (((-114) (-1 (-114) |#2|) $) 22 T ELT)) (-3454 (((-114) $ $) 95 T ELT)) (-3086 (((-114) $ $) 99 T ELT)))
(((-18 |#1| |#2|) (-10 -8 (-15 -3454 ((-114) |#1| |#1|)) (-15 -4376 ((-877) |#1|)) (-15 -3086 ((-114) |#1| |#1|)) (-15 -1933 (|#1| |#1|)) (-15 -1933 (|#1| (-1 (-114) |#2| |#2|) |#1|)) (-15 -2510 (|#1| |#1|)) (-15 -1934 (|#1| |#1| |#1| (-558))) (-15 -1935 ((-114) |#1|)) (-15 -3938 (|#1| |#1| |#1|)) (-15 -3839 ((-558) |#2| |#1| (-558))) (-15 -3839 ((-558) |#2| |#1|)) (-15 -3839 ((-558) (-1 (-114) |#2|) |#1|)) (-15 -1935 ((-114) (-1 (-114) |#2| |#2|) |#1|)) (-15 -3938 (|#1| (-1 (-114) |#2| |#2|) |#1| |#1|)) (-15 -4218 (|#2| |#1| (-1255 (-558)) |#2|)) (-15 -2517 (|#1| |#1| |#1| (-558))) (-15 -2517 (|#1| |#2| |#1| (-558))) (-15 -2518 (|#1| |#1| (-1255 (-558)))) (-15 -2518 (|#1| |#1| (-558))) (-15 -4388 (|#1| (-1 |#2| |#2| |#2|) |#1| |#1|)) (-15 -4232 (|#1| (-661 |#1|))) (-15 -4232 (|#1| |#1| |#1|)) (-15 -4232 (|#1| |#2| |#1|)) (-15 -4232 (|#1| |#1| |#2|)) (-15 -4230 (|#1| |#1| (-1255 (-558)))) (-15 -3950 (|#1| (-661 |#2|))) (-15 -1468 ((-3 |#2| "failed") (-1 (-114) |#2|) |#1|)) (-15 -4272 (|#2| (-1 |#2| |#2| |#2|) |#1|)) (-15 -4272 (|#2| (-1 |#2| |#2| |#2|) |#1| |#2|)) (-15 -4272 (|#2| (-1 |#2| |#2| |#2|) |#1| |#2| |#2|)) (-15 -4230 (|#2| |#1| (-558))) (-15 -4230 (|#2| |#1| (-558) |#2|)) (-15 -4218 (|#2| |#1| (-558) |#2|)) (-15 -2157 ((-791) |#2| |#1|)) (-15 -3290 ((-661 |#2|) |#1|)) (-15 -2157 ((-791) (-1 (-114) |#2|) |#1|)) (-15 -2158 ((-114) (-1 (-114) |#2|) |#1|)) (-15 -2159 ((-114) (-1 (-114) |#2|) |#1|)) (-15 -2160 (|#1| (-1 |#2| |#2|) |#1|)) (-15 -4388 (|#1| (-1 |#2| |#2|) |#1|)) (-15 -3820 (|#1| |#1|))) (-19 |#2|) (-1238)) (T -18))
NIL
diff --git a/src/share/algebra/operation.daase b/src/share/algebra/operation.daase
index 16430dd8..463757e3 100644
--- a/src/share/algebra/operation.daase
+++ b/src/share/algebra/operation.daase
@@ -1,5 +1,5 @@
-(719417 . 3522680062)
+(719417 . 3522866254)
(((*1 *2 *3 *4)
(|partial| -12 (-5 *3 (-1288 *4)) (-4 *4 (-13 (-1070) (-658 (-558))))
(-5 *2 (-1288 (-419 (-558)))) (-5 *1 (-1317 *4)))))
diff --git a/src/utils/storage.H b/src/utils/storage.H
index 72b9eb1e..f2fdc8ae 100644
--- a/src/utils/storage.H
+++ b/src/utils/storage.H
@@ -42,6 +42,7 @@
#include <new>
#include <cmath>
#include <string>
+#include <iterator>
#include <open-axiom/config>
@@ -195,6 +196,28 @@ namespace OpenAxiom {
size_t population() const;
protected:
+ // +----+----+--+-----
+ // | | | |
+ // +----+----+--+-----
+ // ^ ^ ^ ^
+ // | | | `-- first allocatable T object
+ // | | `-- possible padding for proper T alignment
+ // | `-- link to next storage pages
+ // `-- link to previous storage pages
+ enum {
+ link_size = sizeof(Storage*)
+ };
+
+ // The `previous' link in the chain of storage.
+ static Storage*& previous(Storage* s) {
+ return *static_cast<Storage**>(s->at_offset(0));
+ }
+
+ // The `next' link in the chain of storage.
+ static Storage*& next(Storage* s) {
+ return *static_cast<Storage**>(s->at_offset(link_size));
+ }
+
// Address of the first object of type `T' in a storage.
static T* first_object(Handle* h) {
return static_cast<T*>(BlockStorage::begin(h));
@@ -264,6 +287,18 @@ namespace OpenAxiom {
Factory() : Arena<T>(nominal_population()) { }
~Factory();
+ iterator begin() {
+ Storage* s = this->store;
+ while (Storage* p = Arena<T>::previous(s))
+ s = p;
+ return iterator(s, Arena<T>::first_object(s));
+ }
+
+ iterator end() {
+ Storage* s = this->store;
+ return iterator(s, static_cast<T*>(s->next_available()));
+ }
+
// Allocate storage and value-construct an object of type `T'.
T* make() {
return new(this->allocate(1)) T();
@@ -307,6 +342,47 @@ namespace OpenAxiom {
}
}
+ template<typename T>
+ struct Factory<T>::iterator:
+ std::iterator<std::forward_iterator_tag, T> {
+
+ iterator& operator++() {
+ if (ptr < store->next_available()) {
+ ++ptr;
+ return *this;
+ }
+ store = Arena<T>::next(store);
+ ptr = Arena<T>::first_object(store);
+ return *this;
+ }
+
+ iterator operator++(int) {
+ iterator t = *this;
+ ++*this;
+ return t;
+ }
+
+ T* operator->() { return ptr; }
+
+ T& operator*() { return *ptr; }
+
+ friend bool operator==(iterator p, iterator q) {
+ return p.store == q.store and p.ptr == q.ptr;
+ }
+
+ friend bool operator!=(iterator p, iterator q) {
+ return not(p == q);
+ }
+
+ private:
+ Storage* store;
+ T* ptr;
+ friend class Factory<T>;
+
+ iterator(Storage* s, T* p) : store(s), ptr(p) { }
+
+ };
+
// -----------------
// -- FileMapping --
// -----------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-23 18:37:22 +0000