diff options
Diffstat (limited to 'src/boot/strap')
| -rw-r--r-- | src/boot/strap/ast.clisp | 5 | ||||
| -rw-r--r-- | src/boot/strap/utility.clisp | 75 |
2 files changed, 72 insertions, 8 deletions
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index a6f77349..0f152136 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -1362,7 +1362,7 @@ (SETQ |bfVar#109| (CDR |bfVar#109|)))) (SETQ |bfVar#106| (CDR |bfVar#106|)) (SETQ |bfVar#107| (CDR |bfVar#107|))))) - (SETQ |body| (SUBLIS |sb| |body|)) + (SETQ |body| (|applySubst| |sb| |body|)) (SETQ |sb2| (LET ((|bfVar#112| NIL) (|bfVar#113| NIL) (|bfVar#110| |sgargl|) (|i| NIL) @@ -1384,7 +1384,8 @@ (SETQ |bfVar#110| (CDR |bfVar#110|)) (SETQ |bfVar#111| (CDR |bfVar#111|))))) (SETQ |body| - (LIST 'SUBLIS (CONS 'LIST |sb2|) (LIST 'QUOTE |body|))) + (LIST '|applySubst| (CONS 'LIST |sb2|) + (LIST 'QUOTE |body|))) (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|)) (SETQ |def| (LIST |op| |lamex|)) (CONS (|shoeComp| |def|) diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp index 97428682..3d5aca1f 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| |applySubst|)) + |setDifference| |applySubst| |applySubst!| |remove|)) (DEFUN |objectMember?| (|x| |l|) (LOOP @@ -155,18 +155,27 @@ (T |s|))))) (DEFUN |applySubst| (|sl| |t|) - (PROG (|tl| |hd| |p|) + (PROG (|p| |tl| |hd|) (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|)))) + ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) + (CDR |p|)) + (T |t|))))) + +(DEFUN |applySubst!| (|sl| |t|) + (PROG (|p| |tl| |hd|) + (RETURN + (COND + ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|))) + (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|) + (RPLACD |t| |tl|)) + ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) + (CDR |p|)) (T |t|))))) (DEFUN |setDifference| (|x| |y|) @@ -189,3 +198,57 @@ (SETQ |bfVar#1| (CDR |bfVar#1|)))) (CDR |l|)))))) +(DEFUN |removeSymbol| (|l| |x|) + (PROG (|y| |LETTMP#1| |l'| |before|) + (RETURN + (PROGN + (SETQ |before| NIL) + (SETQ |l'| |l|) + (LOOP + (COND + ((NOT (CONSP |l'|)) (RETURN |l|)) + (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|)) + (SETQ |l'| (CDR |LETTMP#1|)) + (COND + ((EQ |x| |y|) + (RETURN (|append!| (|reverse!| |before|) |l'|))) + (T (SETQ |before| (CONS |y| |before|))))))))))) + +(DEFUN |removeScalar| (|l| |x|) + (PROG (|y| |LETTMP#1| |l'| |before|) + (RETURN + (PROGN + (SETQ |before| NIL) + (SETQ |l'| |l|) + (LOOP + (COND + ((NOT (CONSP |l'|)) (RETURN |l|)) + (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|)) + (SETQ |l'| (CDR |LETTMP#1|)) + (COND + ((EQL |x| |y|) + (RETURN (|append!| (|reverse!| |before|) |l'|))) + (T (SETQ |before| (CONS |y| |before|))))))))))) + +(DEFUN |removeValue| (|l| |x|) + (PROG (|y| |LETTMP#1| |l'| |before|) + (RETURN + (PROGN + (SETQ |before| NIL) + (SETQ |l'| |l|) + (LOOP + (COND + ((NOT (CONSP |l'|)) (RETURN |l|)) + (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|)) + (SETQ |l'| (CDR |LETTMP#1|)) + (COND + ((EQUAL |x| |y|) + (RETURN (|append!| (|reverse!| |before|) |l'|))) + (T (SETQ |before| (CONS |y| |before|))))))))))) + +(DEFUN |remove| (|l| |x|) + (COND + ((SYMBOLP |x|) (|removeSymbol| |l| |x|)) + ((OR (CHARACTERP |x|) (INTEGERP |x|)) (|removeScalar| |l| |x|)) + (T (|removeValue| |l| |x|)))) + |