aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-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
10 files changed, 82 insertions, 141 deletions
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)
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-03 10:16:30 +0000