aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog8
-rw-r--r--src/boot/strap/parser.clisp4
-rw-r--r--src/boot/strap/tokens.clisp12
-rw-r--r--src/boot/strap/translator.clisp2
-rw-r--r--src/boot/strap/utility.clisp42
-rw-r--r--src/boot/utility.boot10
-rw-r--r--src/interp/define.boot20
-rw-r--r--src/interp/nruncomp.boot22
8 files changed, 86 insertions, 34 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 98e0770e..9b8adf19 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,13 @@
2013-06-14 Gabriel Dos Reis <gdr@integrable-solutions.net>
+ * interp/nruncomp.boot (NRTsetVector4Part1): Add environment parameter.
+ Adjust caller.
+ (NRTsetVector4a): Likewise. Avoid special variable for environment.
+ * boot/utility.boot: Add and export substSource, substTarget.
+ * interp/define.boot: Use them.
+
+2013-06-14 Gabriel Dos Reis <gdr@integrable-solutions.net>
+
* interp/compiler.boot (categoryInstance?): New.
(compColon): Use it for category definitions.
* interp/c-util.boot: Add accessors for infovec parts.
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index 985611d3..fcb8a2ef 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -388,7 +388,7 @@
(COND (|done| (RETURN NIL))
(T
(SETQ |found|
- (LET ((#1=#:G720
+ (LET ((#1=#:G727
(CATCH :OPEN-AXIOM-CATCH-POINT
(APPLY |f| |ps| NIL))))
(COND
@@ -1371,7 +1371,7 @@
(SETQ |op| (|enclosingFunction| (|parserLoadUnit| |ps|)))
(SETQ |varno| (|parserGensymSequenceNumber| |ps|))
(UNWIND-PROTECT
- (LET ((#1=#:G721
+ (LET ((#1=#:G728
(CATCH :OPEN-AXIOM-CATCH-POINT
(PROGN
(SETF (|enclosingFunction| (|parserLoadUnit| |ps|)) NIL)
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index afd689ad..55653a76 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -84,10 +84,10 @@
(LET* (|s|)
(COND
((SETQ |s|
- (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G726 |shoeKeyTable|)
(LET ((|bfVar#1| NIL))
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G720 |k| |v|)
+ (MULTIPLE-VALUE-BIND (#2=#:G727 |k| |v|)
(#1#)
(COND ((NOT #2#) (RETURN |bfVar#1|))
(T
@@ -138,9 +138,9 @@
(COND ((> |i| 255) (RETURN NIL)) (T (SETF (ELT |a| |i|) |b|)))
(SETQ |i| (+ |i| 1))))
|a|))
- (WITH-HASH-TABLE-ITERATOR (#1=#:G721 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G728 |shoeKeyTable|)
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G722 |s| #:G723)
+ (MULTIPLE-VALUE-BIND (#2=#:G729 |s| #:G730)
(#1#)
(COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
|d|)))
@@ -154,9 +154,9 @@
(LET ((|i| 0))
(LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
(SETQ |i| (+ |i| 1))))
- (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G731 |shoeKeyTable|)
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G725 |k| #:G726)
+ (MULTIPLE-VALUE-BIND (#2=#:G732 |k| #:G733)
(#1#)
(COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL)
(T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))))))
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index d3f85676..99d7f82a 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -416,7 +416,7 @@
(SETQ |ps| (|makeParserState| |toks|))
(|bpFirstTok| |ps|)
(SETQ |found|
- (LET ((#1=#:G729
+ (LET ((#1=#:G736
(CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem| |ps|))))
(COND
((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index 2e303001..1a288c10 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -20,10 +20,10 @@
|lastNode| |append| |append!| |copyList| |substitute|
|substitute!| |setDifference| |setUnion| |setIntersection|
|symbolAssoc| |applySubst| |applySubst!| |applySubstNQ|
- |objectAssoc| |remove| |removeSymbol| |atomic?| |every?|
- |any?| |take| |takeWhile| |drop| |copyTree| |finishLine|
- |stringPrefix?| |stringSuffix?| |findChar|
- |charPosition|)))
+ |objectAssoc| |invertSubst| |substTarget| |substSource|
+ |remove| |removeSymbol| |atomic?| |every?| |any?| |take|
+ |takeWhile| |drop| |copyTree| |finishLine| |stringPrefix?|
+ |stringSuffix?| |findChar| |charPosition|)))
(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|))
@@ -338,6 +338,40 @@
((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
(T |t|))))
+(DEFUN |invertSubst| (|sl|)
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |sl|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2| #1=(CONS (CONS (CDR |x|) (CAR |x|)) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
+(DEFUN |substSource| (|sl|)
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |sl|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (CAR |x|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
+(DEFUN |substTarget| (|sl|)
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |sl|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (CDR |x|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
(DEFUN |setDifference| (|x| |y|)
(LET* (|a| |l| |p|)
(COND ((NULL |x|) NIL) ((NULL |y|) |x|)
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 839e9b1a..d3f999ad 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -48,7 +48,7 @@ module utility (objectMember?, symbolMember?, stringMember?,
lastNode, append, append!, copyList, substitute, substitute!,
setDifference, setUnion, setIntersection,
symbolAssoc, applySubst, applySubst!, applySubstNQ, objectAssoc,
- invertSubst,
+ invertSubst, substTarget, substSource,
remove, removeSymbol, atomic?, every?, any?, take, takeWhile, drop,
copyTree, finishLine, stringPrefix?, stringSuffix?,
findChar, charPosition) where
@@ -285,6 +285,14 @@ applySubstNQ(sl,t) ==
invertSubst sl ==
[[rest x,:first x] for x in sl]
+++ Return the list of source values of a map given by a alist.
+substSource sl ==
+ [first x for x in sl]
+
+++ Return the list of target values of a map given by a alist.
+substTarget sl ==
+ [rest x for x in sl]
+
--% set operations
setDifference(x,y) ==
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 10403767..0195e4e2 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -479,7 +479,7 @@ depthAssocList(u,cache) ==
depthAssoc(x,cache) ==
y := tableValue(cache,x) => y
- x is ['Join,:u] or (u := ASSOCLEFT parentsOfForm x) =>
+ x is ['Join,:u] or (u := substSource parentsOfForm x) =>
v := depthAssocList(u,cache)
tableValue(cache,x) := [[x,:n],:v]
where n() == 1 + "MAX"/[rest y for y in v]
@@ -487,20 +487,20 @@ depthAssoc(x,cache) ==
NRTmakeCategoryAlist(db,e) ==
pcAlist := [:[[x,:true] for x in $uncondAlist],:$condAlist]
- levelAlist := depthAssocList(ASSOCLEFT pcAlist,hashTable 'EQUAL)
+ levelAlist := depthAssocList(substSource pcAlist,hashTable 'EQUAL)
opcAlist := sortBy(function(x +-> LASSOC(first x,levelAlist)),pcAlist)
- newPairlis := [[5 + i,:b] for [.,:b] in dbFormalSubst db for i in 1..]
+ newPairlis := [[i,:b] for [.,:b] in dbFormalSubst db for i in 6..]
slot1 := [[a,:k] for [a,:b] in dbSubstituteAllQuantified(db,opcAlist)
| (k := predicateBitIndex(b,e)) ~= -1]
- slot0 := [hasDefaultPackage a.op for [a,:b] in slot1]
+ slot0 := [hasDefaultPackage a.op for [a,:.] in slot1]
sixEtc := [5 + i for i in 1..dbArity db]
- formals := ASSOCRIGHT dbFormalSubst db
+ formals := substTarget dbFormalSubst db
for x in slot1 repeat
x.first := applySubst(pairList(['$,:formals],["$$",:sixEtc]),first x)
-----------code to make a new style slot4 -----------------
- predList := ASSOCRIGHT slot1 --is list of predicate indices
+ predList := substTarget slot1 --is list of predicate indices
maxPredList := "MAX"/predList
- catformvec := ASSOCLEFT slot1
+ catformvec := substSource slot1
maxElement := "MAX"/dbByteList db
['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList],
['CONS, MKQ vector slot0,
@@ -625,7 +625,7 @@ catExtendsCat?(u,v,tbl,env) ==
PRINT similarForm
sayBrightlyNT '" but not "
PRINT v
- or/[catExtendsCat?(x,v,tbl,env) for x in ASSOCLEFT categoryAncestors uvec]
+ or/[catExtendsCat?(x,v,tbl,env) for x in substSource categoryAncestors uvec]
substSlotNumbers(form,template,domain) ==
form is ['SIGNATURE,op,sig,:q] =>
@@ -1098,7 +1098,7 @@ deduceImplicitParameters(db,e) ==
buildConstructorCondition db ==
dbImplicitData db is [subst,cond] =>
- ['%exist,ASSOCRIGHT subst,mkpf(applySubst(subst,cond),'AND)]
+ ['%exist,substTarget subst,mkpf(applySubst(subst,cond),'AND)]
true
getArgumentMode: (%Form,%Env) -> %Maybe %Mode
@@ -1763,7 +1763,7 @@ compDefWhereClause(['DEF,form,signature,body],m,e) ==
-- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that
-- the type of xi is independent of xj if i < j
varList :=
- orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where
+ orderByDependency(substSource argDepAlist,substTarget argDepAlist) where
argDepAlist :=
[[x,:dependencies] for [x,:y] in argSigAlist] where
dependencies() ==
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index bd6424fd..0271c9a4 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.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-2013, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -480,7 +480,7 @@ buildFunctor(db,sig,code,$locals,$e) ==
-- Do this now to create predicate vector; then DescendCode can refer
-- to predicate vector if it can
[$uncondAlist,:$condAlist] := --bound in compDefineFunctor1
- NRTsetVector4Part1(db,viewNames,catvecListMaker,condCats)
+ NRTsetVector4Part1(db,viewNames,catvecListMaker,condCats,$e)
[$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] :=
makePredicateBitVector(db,[:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList],$e)
@@ -527,13 +527,13 @@ buildFunctor(db,sig,code,$locals,$e) ==
SAY ['"time taken in buildFunctor: ",TEMPUS_-FUGIT()-oldtime]
ans
-NRTsetVector4Part1(db,siglist,formlist,condlist) ==
+NRTsetVector4Part1(db,siglist,formlist,condlist,e) ==
$uncondList: local := nil
$condList: local := nil
$count: local := 0
for sig in reverse siglist for form in reverse formlist
for cond in reverse condlist repeat
- NRTsetVector4a(db,sig,form,cond)
+ NRTsetVector4a(db,sig,form,cond,e)
reducedUncondlist := removeDuplicates $uncondList
reducedConlist :=
[[x,:y] for [x,z] in $condList| y := SETDIFFERENCE(z,reducedUncondlist)]
@@ -551,15 +551,17 @@ reverseCondlist cl ==
u.rest := [x,:rest u]
alist
-NRTsetVector4a(db,sig,form,cond) ==
+NRTsetVector4a(db,sig,form,cond,e) ==
sig is '$ =>
domainList :=
- [optimize comp(d,$EmptyMode,$e).expr or d
- for d in categoryPrincipals dbDomainShell db]
- $uncondList := append(domainList,$uncondList)
- if isCategoryForm(form,$e) then $uncondList := [form,:$uncondList]
+ [domForm for d in categoryPrincipals dbDomainShell db] where
+ domForm() == optimize
+ T := comp(d,$EmptyMode,e) => T.expr
+ d
+ $uncondList := append!(domainList,$uncondList)
+ if isCategoryForm(form,e) then $uncondList := [form,:$uncondList]
$uncondList
- evalform := evalCategoryForm(form,$e)
+ evalform := evalCategoryForm(form,e)
cond is true =>
$uncondList := [form,:append(categoryPrincipals evalform,$uncondList)]
$condList := [[cond,[form,:categoryPrincipals evalform]],:$condList]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 14:09:28 +0000