diff options
Diffstat (limited to 'src/boot')
-rw-r--r-- | src/boot/ast.boot | 9 | ||||
-rw-r--r-- | src/boot/parser.boot | 2 | ||||
-rw-r--r-- | src/boot/strap/ast.clisp | 8 | ||||
-rw-r--r-- | src/boot/strap/parser.clisp | 15 | ||||
-rw-r--r-- | src/boot/strap/utility.clisp | 37 |
5 files changed, 48 insertions, 23 deletions
diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 961cad8f..719d583d 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -359,15 +359,18 @@ bfReduce(op,y)== bfReduceCollect(op,y)== y is ["COLLECT",:.] => - body := y.1 - itl := y.2 + body := second y + itl := third y a := op is ["QUOTE",:.] => second op op op := bfReName a init := a has SHOETHETA or op has SHOETHETA bfOpReduce(op,init,body,itl) - bfReduce(op,bfTupleConstruct (y.1)) + seq := + y = nil => bfTuple nil + second y + bfReduce(op,bfTupleConstruct seq) -- delayed collect diff --git a/src/boot/parser.boot b/src/boot/parser.boot index eeb147ac..7bf4bef4 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -691,6 +691,8 @@ bpCompare()== and (bpIs() or bpTrap()) and bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) or true) + or bpLeave() + or bpThrow() bpAnd() == bpLeftAssoc('(AND),function bpCompare) diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index 4ba335aa..b1e8ab77 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -472,11 +472,11 @@ (|bfLp| |it| |body|))))))) (DEFUN |bfReduceCollect| (|op| |y|) - (PROG (|init| |a| |itl| |body|) + (PROG (|seq| |init| |a| |itl| |body|) (RETURN (COND ((AND (CONSP |y|) (EQ (CAR |y|) 'COLLECT)) - (SETQ |body| (ELT |y| 1)) (SETQ |itl| (ELT |y| 2)) + (SETQ |body| (CADR |y|)) (SETQ |itl| (CADDR |y|)) (SETQ |a| (COND ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) @@ -485,7 +485,9 @@ (SETQ |op| (|bfReName| |a|)) (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) (|bfOpReduce| |op| |init| |body| |itl|)) - (T (|bfReduce| |op| (|bfTupleConstruct| (ELT |y| 1)))))))) + (T (SETQ |seq| + (COND ((NULL |y|) (|bfTuple| NIL)) (T (CADR |y|)))) + (|bfReduce| |op| (|bfTupleConstruct| |seq|))))))) (DEFUN |bfDCollect| (|y| |itl|) (LIST 'COLLECT |y| |itl|)) diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index afed4d9f..b3ef4b0e 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -747,13 +747,14 @@ (AND (|bpBracket| |f|) (|bpPush| (|bfConstruct| (|bpPop1|))))) (DEFUN |bpCompare| () - (AND (|bpIs|) - (OR (AND (|bpInfKey| '(SHOEEQ SHOENE LT LE GT GE IN)) - (OR (|bpIs|) (|bpTrap|)) - (|bpPush| - (|bfInfApplication| (|bpPop2|) (|bpPop2|) - (|bpPop1|)))) - T))) + (OR (AND (|bpIs|) + (OR (AND (|bpInfKey| '(SHOEEQ SHOENE LT LE GT GE IN)) + (OR (|bpIs|) (|bpTrap|)) + (|bpPush| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))) + T)) + (|bpLeave|) (|bpThrow|))) (DEFUN |bpAnd| () (|bpLeftAssoc| '(AND) #'|bpCompare|)) diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp index e52d92ea..c1799071 100644 --- a/src/boot/strap/utility.clisp +++ b/src/boot/strap/utility.clisp @@ -14,21 +14,38 @@ (OR (EQ |x| (CAR |l|)) (|objectMember?| |x| (CDR |l|)))) (T (EQ |x| |l|)))) -(DEFUN |genericMember?| (|x| |l| |p|) +(DEFUN |symbolMember?| (|s| |l|) (COND ((NULL |l|) NIL) ((CONSP |l|) - (OR (APPLY |p| |x| (CAR |l|) NIL) - (|genericMember?| |x| (CDR |l|) |p|))) - (T (APPLY |p| |x| |l| NIL)))) + (OR (EQ |s| (CAR |l|)) (|symbolMember?| |s| (CDR |l|)))) + (T (EQ |s| |l|)))) -(DEFUN |symbolMember?| (|x| |l|) (|genericMember?| |x| |l| #'EQ)) - -(DEFUN |stringMember?| (|s| |l|) (|genericMember?| |s| |l| #'STRING=)) +(DEFUN |stringMember?| (|s| |l|) + (COND + ((NULL |l|) NIL) + ((CONSP |l|) + (OR (STRING= |s| (CAR |l|)) (|stringMember?| |s| (CDR |l|)))) + (T (STRING= |s| |l|)))) -(DEFUN |charMember?| (|c| |l|) (|genericMember?| |c| |l| #'CHAR=)) +(DEFUN |charMember?| (|c| |l|) + (COND + ((NULL |l|) NIL) + ((CONSP |l|) + (OR (CHAR= |c| (CAR |l|)) (|charMember?| |c| (CDR |l|)))) + (T (CHAR= |c| |l|)))) -(DEFUN |scalarMember?| (|x| |l|) (|genericMember?| |x| |l| #'EQL)) +(DEFUN |scalarMember?| (|x| |l|) + (COND + ((NULL |l|) NIL) + ((CONSP |l|) + (OR (EQL |x| (CAR |l|)) (|scalarMember?| |x| (CDR |l|)))) + (T (CHAR= |x| |l|)))) -(DEFUN |listMember?| (|x| |l|) (|genericMember?| |x| |l| #'EQUAL)) +(DEFUN |listMember?| (|x| |l|) + (COND + ((NULL |l|) NIL) + ((CONSP |l|) + (OR (EQUAL |x| (CAR |l|)) (|listMember?| |x| (CDR |l|)))) + (T (EQUAL |x| |l|)))) |