aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/c-util.boot50
-rw-r--r--src/interp/define.boot11
-rw-r--r--src/interp/functor.boot12
3 files changed, 66 insertions, 7 deletions
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 080e683d..be616cc5 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -38,6 +38,7 @@ namespace BOOT
module c_-util where
clearReplacement: %Symbol -> %Thing
replaceSimpleFunctions: %Form -> %Form
+ foldExportedFunctionReferences: %List -> %List
--%
++ if true continue compiling after errors
@@ -836,6 +837,30 @@ ambiguousSignatureError(op, sigs) ==
stackSemanticError(['"signature of lhs not unique. Candidates are:",
:displayAmbiguousSignatures($op,sigs)],nil)
+
+--% Capsule Directory Management
+
+++ Holds the list of slot number-export function pairs of
+++ the current functor.
+$capsuleDirectory := nil
+
+clearCapsuleDirectory() ==
+ $capsuleDirectory := nil
+ $capsuleFunctionStack := nil
+
+++ Return the linkage name of the exported operation associated with
+++ slot number `slot'. A nil entry means that either the operation
+++ is not defined, or it is conditional.
+getCapsuleDirectoryEntry slot ==
+ rest ASSOC(slot,$capsuleDirectory)
+
+++ Update the current capsule directory with entry controlled by
+++ predicate `pred'.
+updateCapsuleDirectory(entry,pred) ==
+ pred ^= true => nil
+ entry isnt ["$",slot,["CONS",["dispatchFunction",fun],:.],:.] => nil
+ $capsuleDirectory := [[slot,:fun],:$capsuleDirectory]
+
--%
-- A function is simple if it looks like a super combinator, and it
@@ -895,6 +920,31 @@ replaceSimpleFunctions form ==
not EQ(fun',fun) => rplac(first form,fun')
form
+
+++ Replace all SPADCALLs to operations defined in the current
+++ domain. Conditional operations are not folded.
+foldSpadcall: %Form -> %Form
+foldSpadcall form ==
+ isAtomicForm form => form
+ for args in tails rest form repeat
+ foldSpadcall first args
+ first form isnt "SPADCALL" => form
+ fun := lastNode form
+ fun isnt [["getShellEntry","$",slot]] => form
+ null (op := getCapsuleDirectoryEntry slot) => form
+ rplac(first fun, "$")
+ rplac(first form, op)
+
+
+++ `defs' is a list of function definitions from the current domain.
+++ Walk that list and replace references to unconditional operations
+++ with their corresponding linkage names.
+foldExportedFunctionReferences defs ==
+ for fun in defs repeat
+ foldSpadcall fun is [.,lamex] =>
+ rplac(third lamex, replaceSimpleFunctions third lamex)
+ defs
+
++ record optimizations permitted at level `level'.
setCompilerOptimizations level ==
level = nil => nil
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 7dc8a79a..a2af1e8a 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -663,10 +663,15 @@ disallowNilAttribute x ==
compFunctorBody(body,m,e,parForm) ==
$bootStrapMode = true =>
[bootStrapError($functorForm, _/EDITFILE),m,e]
- $capsuleFunctionStack := nil -- start collecting capsule functions.
+ clearCapsuleDirectory() -- start collecting capsule functions.
T:= compOrCroak(body,m,e)
- COMP $capsuleFunctionStack
- $capsuleFunctionStack := nil -- release storage.
+ $capsuleFunctionStack := nreverse $capsuleFunctionStack
+ -- ??? Don't resolve default definitions, yet.
+ if $insideCategoryPackageIfTrue then
+ COMP $capsuleFunctionStack
+ else
+ COMP foldExportedFunctionReferences $capsuleFunctionStack
+ clearCapsuleDirectory() -- release storage.
body is [op,:.] and MEMQ(op,'(add CAPSULE)) => T
$NRTaddForm :=
body is ["SubDomain",domainForm,predicate] => domainForm
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index af887d1a..a3e122c6 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -639,6 +639,9 @@ DescendCode(code,flag,viewAssoc,EnvToPass) ==
dom
body:= ['CONS,implem,dom]
u:= SetFunctionSlots(sig,body,flag,'original)
+ -- ??? We do not resolve default definitions, yet.
+ if not $insideCategoryPackageIfTrue then
+ updateCapsuleDirectory(rest u, flag)
ConstantCreator u =>
if not (flag=true) then u:= ['COND,[ProcessCond(flag,viewAssoc),u]]
$ConstantAssignments:= [u,:$ConstantAssignments]
@@ -657,9 +660,10 @@ DescendCode(code,flag,viewAssoc,EnvToPass) ==
code
ConstantCreator u ==
- null u => nil
- u is [q,.,.,u'] and (q in '(setShellEntry SETELT QSETREFV)) => ConstantCreator u'
- u is ['CONS,:.] => nil
+ null u => false
+ u is [q,.,.,u'] and (q in '(setShellEntry SETELT QSETREFV)) =>
+ ConstantCreator u'
+ u is ['CONS,:.] => false
true
ProcessCond(cond,viewassoc) ==
@@ -683,7 +687,7 @@ SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding"
--+
catNames := ['$]
for u in $catvecList for v in catNames repeat
- null body => return NIL
+ null body => return nil
for catImplem in LookUpSigSlots(sig,u.1) repeat
if catImplem is [q,.,index] and (q='ELT or q='CONST)
then