aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/ChangeLog8
-rw-r--r--src/boot/ast.boot6
-rw-r--r--src/boot/strap/ast.clisp5
-rw-r--r--src/boot/strap/utility.clisp75
-rw-r--r--src/boot/utility.boot49
-rw-r--r--src/interp/vmlisp.lisp15
6 files changed, 128 insertions, 30 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index d0c98595..fa6d0d76 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,13 @@
2011-04-29 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * interp/vmlisp.lisp (remove): Remove.
+ (REMOVEQ, NREMOVEQ): Likewise.
+ * boot/utility.boot (removeSymbol, removeScalar, removeValue)
+ (remove): New.
+ * boot/ast.boot (bfMDef): Use applySubst in lieu of SUBLIS.
+
+2011-04-29 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* boot/utility.boot (assocSymbol): New.
(applySubst): Likewise. Export.
* boot/ast.boot: Use it. Remove SUBLIS and SUBLISLIS.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index e45047aa..ab87e808 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -787,10 +787,10 @@ bfMDef (op,args,body) ==
bfTupleP args => rest args
[args]
[gargl,sgargl,nargl,largl]:=bfGargl argl
- sb:=[[i,:j] for i in nargl for j in sgargl]
- body:= SUBLIS(sb,body)
+ sb := [[i,:j] for i in nargl for j in sgargl]
+ body := applySubst(sb,body)
sb2 := [["CONS",["QUOTE",i],j] for i in sgargl for j in largl]
- body := ["SUBLIS",["LIST",:sb2],["QUOTE",body]]
+ body := ["applySubst",["LIST",:sb2],["QUOTE",body]]
lamex:= ["MLAMBDA",gargl,body]
def:= [op,lamex]
[shoeComp def,:[:shoeComps bfDef1 d for d in $wheredefs]]
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|))))
+
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index e344dc63..16a81067 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -35,7 +35,7 @@ namespace BOOTTRAN
module utility (objectMember?, symbolMember?, stringMember?,
charMember?, scalarMember?, listMember?, reverse, reverse!,
lastNode, append!, copyList, substitute, substitute!, setDifference,
- applySubst)
+ applySubst, applySubst!,remove)
--% membership operators
@@ -164,14 +164,21 @@ substitute(y,x,s) ==
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]
+ symbol? t and (p := assocSymbol(t,sl)) => rest p
+ t
+
+applySubst!(sl,t) ==
+ cons? t =>
+ hd := applySubst!(sl,first t)
+ tl := applySubst!(sl,rest t)
+ t.first := hd
+ t.rest := tl
+ symbol? t and (p := assocSymbol(t,sl)) => rest p
t
--% set operations
@@ -184,3 +191,37 @@ setDifference(x,y) ==
p.rest := [a]
p := rest p
rest l
+
+--% removal
+
+removeSymbol(l,x) ==
+ before := nil
+ l' := l
+ repeat
+ not cons? l' => return l
+ [y,:l'] := l'
+ symbolEq?(x,y) => return append!(reverse! before,l')
+ before := [y,:before]
+
+removeScalar(l,x) ==
+ before := nil
+ l' := l
+ repeat
+ not cons? l' => return l
+ [y,:l'] := l'
+ scalarEq?(x,y) => return append!(reverse! before,l')
+ before := [y,:before]
+
+removeValue(l,x) ==
+ before := nil
+ l' := l
+ repeat
+ not cons? l' => return l
+ [y,:l'] := l'
+ valueEq?(x,y) => return append!(reverse! before,l')
+ before := [y,:before]
+
+remove(l,x) ==
+ symbol? x => removeSymbol(l,x)
+ char? x or integer? x => removeScalar(l,x)
+ removeValue(l,x)
diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp
index b766a79f..590aa4a8 100644
--- a/src/interp/vmlisp.lisp
+++ b/src/interp/vmlisp.lisp
@@ -739,16 +739,6 @@
((and (atom item) (not (arrayp item))) (member item sequence))
(T (member item sequence :test #'equalp))))
-(defun |remove| (list item &optional (count 1))
- (if (integerp count)
- (remove item list :count count :test #'equalp)
- (remove item list :test #'equalp)))
-
-(defun REMOVEQ (list item &optional (count 1))
- (if (integerp count)
- (remove item list :count count :test #'eq)
- (remove item list :test #'eq)))
-
; 14.2 Accessing
(defun |last| (x) (car (lastpair x)))
@@ -787,11 +777,6 @@
(delete item list :count count :test #'equal)
(delete item list :test #'equal)))
-(defun NREMOVEQ (list item &optional (count 1))
- (if (integerp count)
- (delete item list :count count )
- (delete item list )))
-
(defun EFFACE (item list) (delete item list :count 1 :test #'equal))
; 14.6 Miscellaneous
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-02 09:29:16 +0000