diff options
Diffstat (limited to 'src/boot')
| -rw-r--r-- | src/boot/strap/ast.clisp | 8 | ||||
| -rw-r--r-- | src/boot/strap/utility.clisp | 29 | ||||
| -rw-r--r-- | src/boot/utility.boot | 23 |
3 files changed, 57 insertions, 3 deletions
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index 1ab3b6dd..a6f77349 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -1804,7 +1804,13 @@ (PROGN (SETQ |args| (CDR |ISTMP#2|)) T)))))) - (CONS 'VECTOR |args|)) + (RPLACA |x| 'VECTOR) (RPLACD |x| |args|)) + ((AND (CONSP |x|) (EQ (CAR |x|) '|vector|) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) + (EQ (CAR |ISTMP#1|) 'NIL)))) + (RPLACA |x| 'VECTOR) (RPLACD |x| NIL)) (T (|shoeCompTran1| (CAR |x|)) (|shoeCompTran1| (CDR |x|))))))))) diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp index 38951dd9..97428682 100644 --- a/src/boot/strap/utility.clisp +++ b/src/boot/strap/utility.clisp @@ -8,7 +8,7 @@ (EXPORT '(|objectMember?| |symbolMember?| |stringMember?| |charMember?| |scalarMember?| |listMember?| |reverse| |reverse!| |lastNode| |append!| |copyList| |substitute| |substitute!| - |setDifference|)) + |setDifference| |applySubst|)) (DEFUN |objectMember?| (|x| |l|) (LOOP @@ -120,6 +120,18 @@ ((NULL |y|) |x|) (T (RPLACD (|lastNode| |x|) |y|) |x|))) +(DEFUN |assocSymbol| (|s| |al|) + (PROG (|x|) + (RETURN + (LOOP + (COND + ((AND (CONSP |al|) + (PROGN (SETQ |x| (CAR |al|)) (SETQ |al| (CDR |al|)) T)) + (COND + ((AND (CONSP |x|) (EQ |s| (CAR |x|))) + (IDENTITY (RETURN |x|))))) + (T (RETURN NIL))))))) + (DEFUN |substitute!| (|y| |x| |s|) (COND ((NULL |s|) NIL) @@ -142,6 +154,21 @@ (T (CONS |h| |t|)))) (T |s|))))) +(DEFUN |applySubst| (|sl| |t|) + (PROG (|tl| |hd| |p|) + (RETURN + (COND + ((SYMBOLP |t|) + (COND + ((SETQ |p| (|assocSymbol| |t| |sl|)) (CDR |p|)) + (T |t|))) + ((CONSP |t|) (SETQ |hd| (|applySubst| |sl| (CAR |t|))) + (SETQ |tl| (|applySubst| |sl| (CDR |t|))) + (COND + ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) + (T (CONS |hd| |tl|)))) + (T |t|))))) + (DEFUN |setDifference| (|x| |y|) (PROG (|a| |l| |p|) (RETURN diff --git a/src/boot/utility.boot b/src/boot/utility.boot index 0b15569c..e344dc63 100644 --- a/src/boot/utility.boot +++ b/src/boot/utility.boot @@ -34,7 +34,8 @@ import initial_-env namespace BOOTTRAN module utility (objectMember?, symbolMember?, stringMember?, charMember?, scalarMember?, listMember?, reverse, reverse!, - lastNode, append!, copyList, substitute, substitute!, setDifference) + lastNode, append!, copyList, substitute, substitute!, setDifference, + applySubst) --% membership operators @@ -133,6 +134,15 @@ append!(x,y) == lastNode(x).rest := y x +--% a-list + +assocSymbol(s,al) == + repeat + al is [x,:al] => + cons? x and symbolEq?(s,first x) => + return x + return nil + --% substitution substitute!(y,x,s) == @@ -153,6 +163,17 @@ substitute(y,x,s) == [h,:t] s +applySubst(sl,t) == + symbol? t => + p := assocSymbol(t,sl) => rest p + t + cons? t => + hd := applySubst(sl,first t) + tl := applySubst(sl,rest t) + sameObject?(hd,first t) and sameObject?(tl,rest t) => t + [hd,:tl] + t + --% set operations setDifference(x,y) == |