From a6dfa73ce2833cb63ba83294b775ca305342fd6c Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sat, 15 Jun 2013 01:21:04 +0000 Subject: * 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. --- src/ChangeLog | 8 ++++++++ src/boot/strap/parser.clisp | 4 ++-- src/boot/strap/tokens.clisp | 12 ++++++------ src/boot/strap/translator.clisp | 2 +- src/boot/strap/utility.clisp | 42 +++++++++++++++++++++++++++++++++++++---- src/boot/utility.boot | 10 +++++++++- src/interp/define.boot | 20 ++++++++++---------- src/interp/nruncomp.boot | 22 +++++++++++---------- 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,3 +1,11 @@ +2013-06-14 Gabriel Dos Reis + + * 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 * interp/compiler.boot (categoryInstance?): New. 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] -- cgit v1.2.3