aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog7
-rw-r--r--src/boot/ast.boot16
-rw-r--r--src/interp/Makefile.in3
-rw-r--r--src/interp/Makefile.pamphlet3
-rw-r--r--src/interp/compiler.boot1
-rw-r--r--src/interp/database.boot56
-rw-r--r--src/interp/define.boot15
-rw-r--r--src/interp/nruncomp.boot94
-rw-r--r--src/interp/nrunfast.boot35
-rw-r--r--src/interp/nrunopt.boot10
-rw-r--r--src/interp/preparse.lisp1
-rw-r--r--src/interp/sys-utility.boot3
-rw-r--r--src/interp/template.boot323
-rw-r--r--src/interp/wi1.boot2
-rw-r--r--src/interp/wi2.boot4
15 files changed, 176 insertions, 397 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 815f7ec0..8f226992 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,12 @@
2008-11-02 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * interp/Makefile.pamphlet (template.$(FASLEXT)): Remove.
+ * interp/template.boot: Move non-dead code where appropriate.
+ Remove file.
+ * boot/ast.boot (bfQ): Improve.
+
+2008-11-02 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* lisp/core.lisp.in (|$ExtraRuntimeLibraries|): Listify.
(extra-runtime-libs): Tidy.
* lisp/Makefile.in (edit): stringify $(oa_c_runtime_extra) elements.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index f9246218..da023938 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -784,16 +784,12 @@ bfSmintable x==
first x in '(SIZE LENGTH char)
bfQ(l,r)==
- if bfSmintable l or bfSmintable r
- then ["EQL",l,r]
- else if defQuoteId l or defQuoteId r
- then ["EQ",l,r]
- else
- if null l
- then ["NULL",r]
- else if null r
- then ["NULL",l]
- else ["EQUAL",l,r]
+ bfSmintable l or bfSmintable r => ["EQL",l,r]
+ defQuoteId l or defQuoteId r => ["EQ",l,r]
+ null l => ["NULL",r]
+ null r => ["NULL",l]
+ EQ(l,true) or EQ(r,true) => ["EQ",l,r]
+ ["EQUAL",l,r]
bfLessp(l,r)==
if r=0
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 8cff46d0..44f1e0f2 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -84,7 +84,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \
preparse.$(FASLEXT) bootlex.$(FASLEXT) \
spad.$(FASLEXT) \
spaderror.$(FASLEXT) \
- template.$(FASLEXT) termrw.$(FASLEXT) \
+ termrw.$(FASLEXT) \
trace.$(FASLEXT) daase.$(FASLEXT) \
fortcall.$(FASLEXT) i-parser.$(FASLEXT) \
$(OCOBJS) $(BROBJS) $(ASCOMP) $(INOBJS)
@@ -309,7 +309,6 @@ nrunopt.$(FASLEXT): c-util.$(FASLEXT)
nrunfast.$(FASLEXT): c-util.$(FASLEXT)
nruncomp.$(FASLEXT): c-util.$(FASLEXT)
nrungo.$(FASLEXT): c-util.$(FASLEXT)
-template.$(FASLEXT): c-util.$(FASLEXT)
iterator.$(FASLEXT): g-util.$(FASLEXT)
define.$(FASLEXT): cattable.$(FASLEXT) category.$(FASLEXT) c-util.$(FASLEXT)
package.$(FASLEXT): clam.$(FASLEXT)
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index af5850ae..67c3671b 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -163,7 +163,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \
preparse.$(FASLEXT) bootlex.$(FASLEXT) \
spad.$(FASLEXT) \
spaderror.$(FASLEXT) \
- template.$(FASLEXT) termrw.$(FASLEXT) \
+ termrw.$(FASLEXT) \
trace.$(FASLEXT) daase.$(FASLEXT) \
fortcall.$(FASLEXT) i-parser.$(FASLEXT) \
$(OCOBJS) $(BROBJS) $(ASCOMP) $(INOBJS)
@@ -558,7 +558,6 @@ nrunopt.$(FASLEXT): c-util.$(FASLEXT)
nrunfast.$(FASLEXT): c-util.$(FASLEXT)
nruncomp.$(FASLEXT): c-util.$(FASLEXT)
nrungo.$(FASLEXT): c-util.$(FASLEXT)
-template.$(FASLEXT): c-util.$(FASLEXT)
iterator.$(FASLEXT): g-util.$(FASLEXT)
define.$(FASLEXT): cattable.$(FASLEXT) category.$(FASLEXT) c-util.$(FASLEXT)
package.$(FASLEXT): clam.$(FASLEXT)
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 7fd58b82..f40155ce 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -75,6 +75,7 @@ compApplication: (%Form,%List,%Mode,%Env,%Triple) -> %Maybe %Triple
compApplyModemap: (%Form,%Modemap,%Env,%List) -> %Maybe %Triple
primitiveType: %Thing -> %Mode
+modeEqual: (%Form,%Form) -> %Boolean
hasUniqueCaseView: (%Form,%Mode,%Env) -> %Boolean
convertOrCroak: (%Triple,%Mode) -> %Maybe %Triple
getFormModemaps: (%Form,%Env) -> %List
diff --git a/src/interp/database.boot b/src/interp/database.boot
index 06422176..011f15c5 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -57,7 +57,7 @@ pathToDatabase name ==
--%
-getConstructorAbbreviationFromDB: %Symbol -> %Maybe %Symbol
+getConstructorAbbreviationFromDB: %Symbol -> %Symbol
getConstructorAbbreviationFromDB ctor ==
GETDATABASE(ctor,"ABBREVIATION")
@@ -75,7 +75,7 @@ getConstructorAncestorsFromDB ctor ==
++ return the modemap of the constructor or the instantiation
++ of the constructor `form'.
-getConstructorModemapFromDB: %Symbol -> %Maybe %Symbol
+getConstructorModemapFromDB: %Symbol -> %Mode
getConstructorModemapFromDB form ==
GETDATABASE(opOf form, 'CONSTRUCTORMODEMAP)
@@ -271,17 +271,6 @@ getDependentsOfConstructor(con) ==
RSHUT stream
val
-putModemapIntoDatabase(name,modemap,fileName) ==
- $forceAdd: local:= nil
- mml:= ASSOC(name,$databaseQueue)
- if mml = [] then
- $databaseQueue:=[[name, modemap],:$databaseQueue]
- else
- or/[modemap=map' for map' in CDR mml] => "already there"
- newEntry:= [modemap,:CDR mml]
- RPLACD(mml,newEntry)
- newEntry
-
orderPredicateItems(pred1,sig,skip) ==
pred:= signatureTran pred1
pred is ["AND",:l] => orderPredTran(l,sig,skip)
@@ -645,23 +634,6 @@ updateDatabase(fname,cname,systemdir?) ==
clearClams()
clearAllSlams []
-removeCoreModemaps(modemapList,c) ==
- newUserModemaps:= nil
- c := opOf unabbrev c
- for [op,mmList] in modemapList repeat
- temp:= nil
- for mm in mmList repeat
- cname := getDomainFromMm mm
- if cname ^= c then temp:= [:temp,mm]
- if temp then newUserModemaps:= [:newUserModemaps,[op,temp]]
- newUserModemaps
-
-addCoreModemap(modemapList,op,modemap,cname) ==
- entry:= ASSQ(op,modemapList) =>
- RPLAC(CADR entry,[modemap,:CADR entry])
- modemapList
- modeMapList:= [:modemapList,[op,[ modemap]]]
-
REMOVER(lst,item) ==
--destructively removes item from lst
not PAIRP lst =>
@@ -685,6 +657,30 @@ loadDependents fn ==
--% Miscellaneous Stuff
+markUnique x ==
+ u := first x
+ RPLACA(x,'(_$unique))
+ RPLACD(x,[u,:rest x])
+ rest x
+
+getOperationAlistFromLisplib x ==
+ u := getConstructorOperationsFromDB x
+-- u := removeZeroOneDestructively u
+ null u => u -- this can happen for Object
+ CAAR u = '_$unique => rest u
+ f:= addConsDB '(NIL T ELT)
+ for [op,:sigList] in u repeat
+ for items in tails sigList repeat
+ [sig,:r] := first items
+ if r is [.,:s] then
+ if s is [.,:t] then
+ if t is [.] then nil
+ else RPLACD(s,QCDDR f)
+ else RPLACD(r,QCDR f)
+ else RPLACD(first items,f)
+ RPLACA(items,addConsDB CAR items)
+ u and markUnique u
+
getOplistForConstructorForm (form := [op,:argl]) ==
-- The new form is an op-Alist which has entries (<op> . signature-Alist)
-- where signature-Alist has entries (<signature> . item)
diff --git a/src/interp/define.boot b/src/interp/define.boot
index aec9d7ef..4166b0f9 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -294,7 +294,7 @@ compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) ==
nil
[d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal)
if categoryCapsule and not $bootStrapMode then [.,.,e] :=
- $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1
+ $insideCategoryPackageIfTrue: local := true
$categoryPredicateList: local :=
makeCategoryPredicates(form,$lisplibCategory)
compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e)
@@ -335,8 +335,6 @@ mkCategoryPackage(form is [op,:argl],cat,def) ==
catvec := eval mkEvalableCategoryForm form
fullCatOpList:=(JoinInner([catvec],$e)).1
catOpList :=
- --note: this gets too many modemaps in general
- -- this is cut down in NRTmakeSlot1
[['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList
--above line calls the category constructor just compiled
| assoc(op1,capsuleDefAlist)]
@@ -403,8 +401,9 @@ compDefineCategory2(form,signature,specialCases,body,m,e,
['sublisV,['PAIR,['QUOTE,sargl],['LIST,:
[['devaluate,u] for u in sargl]]],body]
body:=
- ['PROG1,["%LET",g:= GENSYM(),body],['SETELT,g,0,mkConstructor $form]]
- fun:= compile [op',['LAM,sargl,body]]
+ ["PROG1",["%LET",g:= GENSYM(),body],
+ ["setShellEntry",g,0,mkConstructor $form]]
+ fun:= compile [op',["LAM",sargl,body]]
-- 5. give operator a 'modemap property
pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList]
@@ -537,9 +536,9 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
REMDUP [CADR x for x in attributeList]
-->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT)
$NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList
- $NRTslot1Info: local := nil --set in NRTmakeSlot1 called by NRTbuildFunctor
+ $NRTslot1Info: local := nil --set in NRTmakeSlot1Info
--this is used below to set $lisplibSlot1 global
- $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1
+ $NRTaddForm: local := nil -- see compAdd
$NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
$NRTdeltaListComp: local := nil --list of compiled forms for $NRTdeltaList
$NRTaddList: local := nil --list of fncts not defined in capsule (added)
@@ -640,7 +639,7 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
[simpBool x for x in $NRTslot1PredicateList]
rwriteLispForm('loadTimeStuff,
['MAKEPROP,MKQ $op,''infovec,getInfovecCode()])
- $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1
+ $lisplibSlot1 := $NRTslot1Info
$lisplibOperationAlist:= operationAlist
$lisplibMissingFunctions:= $CheckVectorList
lisplibWrite('"compilerInfo",
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index db4bd860..9dd8bff1 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -290,6 +290,38 @@ NRTassignCapsuleFunctionSlot(op,sig) ==
$NRTdeltaListComp := [nil,:$NRTdeltaListComp]
$NRTdeltaLength := $NRTdeltaLength+1
+
+++ NRTaddInner should call following function instead of NRTgetLocalIndex
+++ This would prevent putting spurious items in $NRTdeltaList
+NRTinnerGetLocalIndex x ==
+ atom x => x
+ -- following test should skip Unions, Records, Mapping
+ op := first x
+ op in '(Union Record Mapping Enumeration _[_|_|_]) => NRTgetLocalIndex x
+ constructor? op => NRTgetLocalIndex x
+ NRTaddInner x
+
+
+NRTaddInner x ==
+--called by genDeltaEntry and others that affect $NRTdeltaList
+ PROGN
+ atom x => nil
+ x is ['Record,:l] =>
+ for [.,.,y] in l repeat NRTinnerGetLocalIndex y
+ first x in '(Union Mapping _[_|_|_]) =>
+ for y in rest x repeat
+ y is [":",.,z] => NRTinnerGetLocalIndex z
+ NRTinnerGetLocalIndex y
+ x is ['SubDomain,y,:.] => NRTinnerGetLocalIndex y
+ getConstructorSignature first x is [.,:ml] =>
+ for y in rest x for m in ml | not (y = '$) repeat
+ isCategoryForm(m,$CategoryFrame) => NRTinnerGetLocalIndex y
+ x is ["Enumeration",:.] =>
+ for y in rest x repeat NRTinnerGetLocalIndex y
+ keyedSystemError("S2NR0003",[x])
+ x
+
+
NRTisExported? opSig ==
or/[u for u in $domainShell.1 | u.0 = opSig]
@@ -333,6 +365,27 @@ consDomainForm(x,dc) ==
get(x,'value,$e) or get(x,'mode,$e) => x
MKQ x
+
+++ Called by buildFunctor fill $template slots with names
+++ of compiled functions
+NRTdescendCodeTran(u,condList) ==
+ null u => nil
+ u is ['LIST] => nil
+ u is [op,.,i,a] and MEMQ(op,'(setShellEntry SETELT QSETREFV)) =>
+ null condList and a is ['CONS,fn,:.] =>
+ RPLACA(u,'LIST)
+ RPLACD(u,nil)
+ $template.i :=
+ fn = 'IDENTITY => a
+ fn is ['dispatchFunction,fn'] => fn'
+ fn
+ nil --code for this will be generated by the instantiator
+ u is ['COND,:c] =>
+ for [pred,:y] in c|y repeat NRTdescendCodeTran(first y,[pred,:condList])
+ u is ['PROGN,:c] => for x in c repeat NRTdescendCodeTran(x,condList)
+ nil
+
+
buildFunctor($definition is [name,:args],sig,code,$locals,$e) ==
--PARAMETERS
-- $definition: constructor form, e.g. (SquareMatrix 10 (RationalNumber))
@@ -488,9 +541,6 @@ NRTcheckVector domainShell ==
[[first v,:$SetFunctions.i],:alist]
alist
--- Obsolete once we have moved to JHD's world
-NRTvectorCopy(cacheName,domName,deltaLength) == GETREFV ($NRTbase + deltaLength)
-
mkDomainCatName id == INTERN STRCONC(id,";CAT")
NRTsetVector4(siglist,formlist,condlist) ==
@@ -579,11 +629,6 @@ NRTsetVector4a(sig,form,cond) ==
cond = true => $uncondList := [form,:APPEND(evalform.4.0,$uncondList)]
$condList := [[cond,[form,:evalform.4.0]],:$condList]
-NRTmakeSlot1 domainShell ==
- opDirectName := INTERN STRCONC(PNAME first $definition,'";opDirect")
- fun := '(function lookupInCompactTable)
- ["setShellEntry", '$,1, ['LIST,fun,'$,opDirectName]]
-
NRTmakeSlot1Info() ==
-- 4 cases:
-- a:T == b add c --- slot1 directory has #s for entries defined in c
@@ -657,11 +702,11 @@ changeDirectoryInSlot1() == --called by NRTbuildFunctor
$lastPred := pred
newfnsel :=
fnsel is ['Subsumed,op1,sig1] =>
- ['Subsumed,op1,genSlotSig(sig1,"T",$newEnv)]
+ ['Subsumed,op1,genSlotSig(sig1,$newEnv)]
fnsel
- [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel]
+ [[op, genSlotSig(sig,$newEnv)] ,pred,newfnsel]
-genSlotSig(sig,pred,$e) ==
+genSlotSig(sig,$e) ==
[NRTgetLocalIndex t for t in sig]
deepChaseInferences(pred,$e) ==
@@ -693,6 +738,33 @@ NRTsubstDelta(initSig) ==
MEMQ(CAR t,'(Mapping Union Record _:)) =>
[CAR t,:[replaceSlotTypes(x) for x in rest t]]
t
+
+mapConsDB x ==
+ [addConsDB y for y in x]
+
+addConsDB x ==
+ min x where
+ min x ==
+ y:=HGET($consDB,x)
+ y => y
+ PAIRP x =>
+ for z in tails x repeat
+ u:=min CAR z
+ if not EQ(u,CAR z) then RPLACA(z,u)
+ HashCheck x
+ REFVECP x =>
+ for i in 0..MAXINDEX x repeat
+ x.i:=min (x.i)
+ HashCheck x
+ STRINGP x => HashCheck x
+ x
+ HashCheck x ==
+ y:=HGET($consDB,x)
+ y => y
+ HPUT($consDB,x,x)
+ x
+ x
+
-----------------------------SLOT1 DATABASE------------------------------------
updateSlot1DataBase [name,info] == HPUT($Slot1DataBase,name,info)
diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot
index 2b5f55b8..2f419f37 100644
--- a/src/interp/nrunfast.boot
+++ b/src/interp/nrunfast.boot
@@ -65,14 +65,41 @@ isNewWorldDomain domain == INTEGERP domain.3 --see HasCategory/Attribute
getDomainByteVector dom == CDDR dom.4
---------------------> NEW DEFINITION (see interop.boot.pamphlet)
getOpCode(op,vec,max) ==
--search Op vector for "op" returning code if found, nil otherwise
res := nil
for i in 0..max by 2 repeat
EQ(QVELT(vec,i),op) => return (res := QSADD1 i)
res
-
+
+evalSlotDomain(u,dollar) ==
+ $returnNowhereFromGoGet: local := false
+ $ : fluid := dollar -- ??? substitute
+ $lookupDefaults : local := nil -- new world
+ u = '$ => dollar
+ u = "$$" => dollar
+ FIXP u =>
+ VECP (y := dollar.u) => y
+ y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous?
+ y is [v,:.] =>
+ VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt]
+ IDENTP v and constructor? v
+ or MEMQ(v,'(Record Union Mapping Enumeration)) =>
+ lazyDomainSet(y,dollar,u) --new style has lazyt
+ y
+ y
+ u is ['NRTEVAL,y] => eval y
+ u is ['QUOTE,y] => y
+ u is ['Record,:argl] =>
+ apply('Record,[[":",tag,evalSlotDomain(dom,dollar)]
+ for [.,tag,dom] in argl])
+ u is ['Union,:argl] and first argl is ['_:,.,.] =>
+ APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)]
+ for [.,tag,dom] in argl])
+ u is ["Enumeration",:.] => eval u
+ u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl])
+ systemErrorHere '"evalSlotDomain"
+
--=======================================================
-- Lookup From Compiled Code
--=======================================================
@@ -127,10 +154,6 @@ lookupComplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil)
--------------------> NEW DEFINITION (see interop.boot.pamphlet)
lookupIncomplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true)
---------------------> NEW DEFINITION (see interop.boot.pamphlet)
-lookupInCompactTable(op,sig,dollar,env) ==
- newLookupInTable(op,sig,dollar,env,true)
-
newLookupInTable(op,sig,dollar,[domain,opvec],flag) ==
dollar = nil => systemError()
$lookupDefaults = true =>
diff --git a/src/interp/nrunopt.boot b/src/interp/nrunopt.boot
index 124497ed..a4d10e00 100644
--- a/src/interp/nrunopt.boot
+++ b/src/interp/nrunopt.boot
@@ -142,7 +142,8 @@ makeCompactSigCode(sig,$isOpPackageName) == [fn for x in sig] where
fn() ==
x = '_$_$ => 2
x = '$ => 0
- not INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"]
+ not INTEGERP x =>
+ systemError ['"code vector slot is ",x,'"; must be number"]
-- x = 6 and $isOpPackageName => 0 --treat slot 6 as $ for default packages
x
@@ -177,6 +178,13 @@ getLookupFun infovec ==
MAXINDEX infovec = 4 => infovec.4
'lookupIncomplete
+makeSpadConstant [fn,dollar,slot] ==
+ val := FUNCALL(fn,dollar)
+ u:= dollar.slot
+ RPLACA(u,function IDENTITY)
+ RPLACD(u,val)
+ val
+
stuffSlot(dollar,i,item) ==
dollar.i :=
atom item => [SYMBOL_-FUNCTION item,:dollar]
diff --git a/src/interp/preparse.lisp b/src/interp/preparse.lisp
index de612cfd..2b92469e 100644
--- a/src/interp/preparse.lisp
+++ b/src/interp/preparse.lisp
@@ -94,7 +94,6 @@
(defvar $skipme)
-(defvar $COMBLOCKLIST)
(defun PREPARSE (Strm &aux (stack ()))
(SETQ $COMBLOCKLIST NIL $skipme NIL)
diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot
index 977859a3..073bc1c8 100644
--- a/src/interp/sys-utility.boot
+++ b/src/interp/sys-utility.boot
@@ -37,6 +37,9 @@ import sys_-os
import vmlisp
namespace BOOT
+--%
+$COMBLOCKLIST := nil
+
--%
diff --git a/src/interp/template.boot b/src/interp/template.boot
deleted file mode 100644
index d5c4c816..00000000
--- a/src/interp/template.boot
+++ /dev/null
@@ -1,323 +0,0 @@
--- 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.
-
-import c_-util
-namespace BOOT
-
-getOperationAlistFromLisplib x ==
- -- used to be in clammed.boot. Moved on 1/24/94
---+
--- newType? x => getConstructorOperationsFromDB x
- NRTgetOperationAlistFromLisplib x
-
-NRTgetOperationAlistFromLisplib x ==
- u := getConstructorOperationsFromDB x
--- u := removeZeroOneDestructively u
- null u => u -- this can happen for Object
- CAAR u = '_$unique => rest u
- f:= addConsDB '(NIL T ELT)
- for [op,:sigList] in u repeat
- for items in tails sigList repeat
- [sig,:r] := first items
- if r is [.,:s] then
- if s is [.,:t] then
- if t is [.] then nil
- else RPLACD(s,QCDDR f)
- else RPLACD(r,QCDR f)
- else RPLACD(first items,f)
- RPLACA(items,addConsDB CAR items)
- u and markUnique u
-
-markUnique x ==
- u := first x
- RPLACA(x,'(_$unique))
- RPLACD(x,[u,:rest x])
- rest x
-
---=======================================================================
--- Instantiation/Run-Time Operations
---=======================================================================
-
-stuffSlots(dollar,template) ==
- _$: fluid := dollar --??? substitute
- dollarTail := [dollar]
- for i in 5..MAXINDEX template | item := template.i repeat
- dollar.i :=
- atom item => [SYMBOL_-FUNCTION item,:dollar]
- item is ['QUOTE,x] =>
- x is [.,.,:n] and FIXP n => ['goGet,item,:dollarTail]
- ['SETELT,dollar,i,['evalSlotDomain,item,dollar]]
- item is ['CONS,:.] =>
- item is [.,'IDENTITY,['FUNCALL,a,b]] =>
- b = '$ => ['makeSpadConstant,eval a,dollar,i]
- sayBrightlyNT '"Unexpected constant environment!!"
- pp devaluate b
- nil
- sayBrightlyNT '"Unexpected constant format!!"
- pp devaluate item
- nil
- sayBrightlyNT '"Unidentified stuff:"
- pp item
-
---------------------> NEW DEFINITION (see interop.boot.pamphlet)
-evalSlotDomain(u,dollar) ==
- $returnNowhereFromGoGet: local := false
- $ : fluid := dollar -- ??? substitute
- $lookupDefaults : local := nil -- new world
- u = '$ => dollar
- u = "$$" => dollar
- FIXP u =>
- VECP (y := dollar.u) => y
- y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous?
- y is [v,:.] =>
- VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt]
- IDENTP v and constructor? v
- or MEMQ(v,'(Record Union Mapping Enumeration)) =>
- lazyDomainSet(y,dollar,u) --new style has lazyt
- y
- y
- u is ['NRTEVAL,y] => eval y
- u is ['QUOTE,y] => y
- u is ['Record,:argl] =>
- apply('Record,[[":",tag,evalSlotDomain(dom,dollar)]
- for [.,tag,dom] in argl])
- u is ['Union,:argl] and first argl is ['_:,.,.] =>
- APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)]
- for [.,tag,dom] in argl])
- u is ["Enumeration",:.] => eval u
- u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl])
- systemErrorHere '"evalSlotDomain"
-
-
---=======================================================================
--- Loadtime Operations
---=======================================================================
-setLoadTime alist ==
- for [nam,:val] in alist repeat setDynamicBinding(nam,eval val)
-
-setLoadTimeQ alist ==
- for [nam,:val] in alist repeat setDynamicBinding(nam,val)
-
-makeTemplate vec ==
---called at instantiation time by setLoadTime
---the form ['makeTemplate,MKQ $template] is recorded by compDefineFunctor1
--- $template is set below in NRTdescendCodeTran and NRTaddDeltaOpt
- newVec := newShell SIZE vec
- for index in 0..MAXINDEX vec repeat
- item := vec.index
- null item => nil
- item is ['local,:.] => nil --this information used to for display of domains
- newVec.index :=
- atom item => item
- null atom first item =>
- [sig,dcIndex,op,:flag] := item
- code := 4*index
- if dcIndex > 0 then
- code := code + 2 --means "bind"
- else dcIndex := -dcIndex
- if flag = 'CONST then code := code + 1 --means "constant"
- sourceIndex := 8192*dcIndex + code
- uniqueSig:= addConsDB sig
- MKQ [op,uniqueSig,:sourceIndex]
- item is ['CONS,:.] => item --constant case
- MKQ item
- newVec
-
-makeOpDirect u ==
- [nam,[addForm,:opList]] := u
- opList = 'derived => 'derived
- [[op,:[fn y for y in items]] for [op,:items] in opList] where fn y ==
- [sig,:r] := y
- uniqueSig := addConsDB sig
- predCode := 0
- isConstant := false
- r is [subSig,pred,'Subsumed] => [uniqueSig,'subsumed,addConsDB subSig]
- if r is [n,:s] then
- slot :=
- n is [p,:.] => p --the CDR is linenumber of function definition
- n
- if s is [pred,:t] then
- predCode := (pred = 'T => 0; mkUniquePred pred)
- if t is [='CONST,:.] then isConstant := true
- index:= 8192*predCode
- if NUMBERP slot and slot ^= 0 then index := index + 2*slot
- if isConstant then index := index + 1
- [uniqueSig,:index]
-
---=======================================================================
--- Creation of System Sig/Pred Vectors & Hash Tables
---=======================================================================
-
-mkUniquePred pred == putPredHash addConsDB pred
-
-putPredHash pred == --pred MUST have had addConsDB applied to it
- if pred is [op,:u] and MEMQ(op,'(AND OR NOT)) then
- for x in u repeat putPredHash x
- k := HGET($predHash,pred) => k
- HPUT($predHash,pred,$predVectorFrontier)
- if $predVectorFrontier > MAXINDEX $predVector
- then $predVector := extendVectorSize $predVector
- $predVector.$predVectorFrontier := pred
- $predVectorFrontier := $predVectorFrontier + 1
- $predVectorFrontier - 1
-
-extendVectorSize v ==
- n:= MAXINDEX v
- m:= (7*n)/5 -- make 40% longer
- newVec := newShell m
- for i in 0..n repeat newVec.i := v.i
- newVec
-
-mkSigPredVectors() ==
- $predHash:= MAKE_-HASHTABLE 'UEQUAL
- $consDB:= MAKE_-HASHTABLE 'UEQUAL
- $predVectorFrontier:= 1 --slot 0 in vector will be vacant
- $predVector:= newShell 100
- for nam in allConstructors() |
- getConstuctorKindFromDB nam ^= "package" repeat
- for [op,:sigList] in getConstructorOperationsFromDB nam repeat
- for [sig,:r] in sigList repeat
- addConsDB sig
- r is [.,pred,:.] => putPredHash addConsDB pred
- 'done
-
-list2LongerVec(u,n) ==
- vec := newShell ((7*n)/5) -- make 40% longer
- for i in 0.. for x in u repeat vec.i := x
- vec
-
-squeezeConsDB u ==
- fn u where fn u ==
- VECP u => for i in 0..MAXINDEX u repeat fn u.i
- PAIRP u =>
- EQ(x := QCAR u,'QUOTE) => RPLAC(CADR u,addConsDB CADR u)
- squeezeConsDB x
- squeezeConsDB QCDR u
- nil
- u
-
-mapConsDB x == [addConsDB y for y in x]
-addConsDB x ==
- min x where
- min x ==
- y:=HGET($consDB,x)
- y => y
- PAIRP x =>
- for z in tails x repeat
- u:=min CAR z
- if not EQ(u,CAR z) then RPLACA(z,u)
- HashCheck x
- REFVECP x =>
- for i in 0..MAXINDEX x repeat
- x.i:=min (x.i)
- HashCheck x
- STRINGP x => HashCheck x
- x
- HashCheck x ==
- y:=HGET($consDB,x)
- y => y
- HPUT($consDB,x,x)
- x
- x
-
---=======================================================================
--- Functions Creating Lisplib Information
---=======================================================================
-NRTdescendCodeTran(u,condList) ==
---NRTbuildFunctor calls to fill $template slots with names of compiled functions
- null u => nil
- u is ['LIST] => nil
- u is [op,.,i,a] and MEMQ(op,'(setShellEntry SETELT QSETREFV)) =>
- null condList and a is ['CONS,fn,:.] =>
- RPLACA(u,'LIST)
- RPLACD(u,nil)
- $template.i :=
- fn = 'IDENTITY => a
- fn is ['dispatchFunction,fn'] => fn'
- fn
- nil --code for this will be generated by the instantiator
- u is ['COND,:c] =>
- for [pred,:y] in c|y repeat NRTdescendCodeTran(first y,[pred,:condList])
- u is ['PROGN,:c] => for x in c repeat NRTdescendCodeTran(x,condList)
- nil
-
---=======================================================================
--- Miscellaneous Functions
---=======================================================================
-NRTaddInner x ==
---called by genDeltaEntry and others that affect $NRTdeltaList
- PROGN
- atom x => nil
- x is ['Record,:l] =>
- for [.,.,y] in l repeat NRTinnerGetLocalIndex y
- first x in '(Union Mapping _[_|_|_]) =>
- for y in rest x repeat
- y is [":",.,z] => NRTinnerGetLocalIndex z
- NRTinnerGetLocalIndex y
- x is ['SubDomain,y,:.] => NRTinnerGetLocalIndex y
- getConstructorSignature first x is [.,:ml] =>
- for y in rest x for m in ml | not (y = '$) repeat
- isCategoryForm(m,$CategoryFrame) => NRTinnerGetLocalIndex y
- x is ["Enumeration",:.] =>
- for y in rest x repeat NRTinnerGetLocalIndex y
- keyedSystemError("S2NR0003",[x])
- x
-
--- NRTaddInner should call following function instead of NRTgetLocalIndex
--- This would prevent putting spurious items in $NRTdeltaList
-NRTinnerGetLocalIndex x ==
- atom x => x
- -- following test should skip Unions, Records, Mapping
- op := first x
- MEMQ(op,'(Union Record Mapping Enumeration _[_|_|_])) => NRTgetLocalIndex x
- constructor? op => NRTgetLocalIndex x
- NRTaddInner x
-
-assignSlotToPred cond ==
---called by ProcessCond
- cond is ['AND,:u] => ['AND,:[assignSlotToPred x for x in u]]
- cond is ['OR,:u] => ['OR,:[assignSlotToPred x for x in u]]
- cond is ['NOT,u] => ['NOT,assignSlotToPred u]
- thisNeedsTOBeFilledIn()
-
-makeSpadConstant [fn,dollar,slot] ==
- val := FUNCALL(fn,dollar)
- u:= dollar.slot
- RPLACA(u,function IDENTITY)
- RPLACD(u,val)
- val
-
-
-
-
-
diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot
index 0293178c..29ea264e 100644
--- a/src/interp/wi1.boot
+++ b/src/interp/wi1.boot
@@ -1148,7 +1148,7 @@ compDefineCategory1(df,m,e,prefix,fal) ==
-- else
if categoryCapsule and not $bootStrapMode then
[.,.,e] :=
- $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1
+ $insideCategoryPackageIfTrue: local := true
$categoryPredicateList: local :=
makeCategoryPredicates(form,$lisplibCategory)
defform := mkCategoryPackage(form,cat,categoryCapsule)
diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot
index cb2d24c3..38ab1339 100644
--- a/src/interp/wi2.boot
+++ b/src/interp/wi2.boot
@@ -120,9 +120,9 @@ compDefineFunctor1(df, m,$e,$prefix,$formalArgList) ==
REMDUP [CADR x for x in attributeList]
-->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT)
$NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList
- $NRTslot1Info: local := nil --set in NRTmakeSlot1 called by NRTbuildFunctor
+ $NRTslot1Info: local := nil --set in NRTmakeSlot1Info
--this is used below to set $lisplibSlot1 global
- $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1
+ $NRTaddForm: local := nil -- see compAdd
$NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
$NRTdeltaListComp: local := nil --list of compiled forms for $NRTdeltaList
$NRTaddList: local := nil --list of fncts not defined in capsule (added)
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 12:39:49 +0000