aboutsummaryrefslogtreecommitdiff
path: root/src/boot/strap
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot/strap')
-rw-r--r--src/boot/strap/ast.clisp77
-rw-r--r--src/boot/strap/tokens.clisp28
-rw-r--r--src/boot/strap/translator.clisp90
3 files changed, 96 insertions, 99 deletions
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 71922a32..6f4c96da 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -581,9 +581,41 @@
(SETQ |bfVar#1| (CDR |bfVar#1|))))
(LIST (|reverse!| |x|) (|reverse!| |y|))))))
+(DEFUN |bfTableIteratorBindingForm| (|keyval| |end?| |succ|)
+ (PROG (|k| |v| |val| |ISTMP#2| |key| |ISTMP#1|)
+ (RETURN
+ (COND
+ ((AND (CONSP |keyval|) (EQ (CAR |keyval|) 'CONS)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |keyval|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |key| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |val| (CAR |ISTMP#2|)) T))))))
+ (COND ((EQ |key| 'DOT) (SETQ |key| (GENSYM))))
+ (COND ((EQ |val| 'DOT) (SETQ |val| (GENSYM))))
+ (COND
+ ((AND (|ident?| |key|) (|ident?| |val|))
+ (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |key| |val|) (LIST |succ|)))
+ ((|ident?| |key|) (SETQ |v| (GENSYM))
+ (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |key| |v|) (LIST |succ|)
+ (|bfLET| |val| |v|)))
+ (T (SETQ |k| (GENSYM))
+ (COND
+ ((|ident?| |val|)
+ (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |val|) (LIST |succ|)
+ (|bfLET| |key| |k|)))
+ (T (SETQ |v| (GENSYM))
+ (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|)
+ (|bfLET| |key| |k|) (|bfLET| |val| |v|)))))))
+ (T (SETQ |k| (GENSYM)) (SETQ |v| (GENSYM))
+ (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|)
+ (|bfLET| |keyval| (LIST 'CONS |k| |v|))))))))
+
(DEFUN |bfExpandTableIters| (|iters|)
- (PROG (|ISTMP#5| |v| |ISTMP#4| CONS |ISTMP#3| |k| |x| |g| |ISTMP#2| |t|
- |ISTMP#1| |e| |exits| |localBindings| |inits|)
+ (PROG (|x| |g| |ISTMP#2| |t| |ISTMP#1| |e| |exits| |localBindings| |inits|)
(RETURN
(PROGN
(SETQ |inits| NIL)
@@ -610,44 +642,9 @@
(SETQ |inits| (CONS (LIST |g| |t|) |inits|))
(SETQ |x| (GENSYM))
(SETQ |exits| (CONS (LIST 'NOT |x|) |exits|))
- (COND
- ((AND (CONSP |e|) (EQ (CAR |e|) 'CONS)
- (PROGN
- (SETQ |ISTMP#1| (CDR |e|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |k| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN
- (SETQ |ISTMP#3| (CAR |ISTMP#2|))
- (AND (CONSP |ISTMP#3|)
- (PROGN
- (SETQ CONS (CAR |ISTMP#3|))
- (SETQ |ISTMP#4| (CDR |ISTMP#3|))
- (AND (CONSP |ISTMP#4|)
- (PROGN
- (SETQ |v| (CAR |ISTMP#4|))
- (SETQ |ISTMP#5|
- (CDR |ISTMP#4|))
- (AND (CONSP |ISTMP#5|)
- (NULL (CDR |ISTMP#5|))
- (EQ (CAR |ISTMP#5|)
- 'NIL)))))))))))
- (|ident?| |k|) (|ident?| |v|))
- (SETQ |localBindings|
- (CONS
- (LIST 'MULTIPLE-VALUE-BIND (LIST |x| |k| |v|)
- (LIST |g|))
- |localBindings|)))
- (T (SETQ |k| (GENSYM)) (SETQ |v| (GENSYM))
- (SETQ |localBindings|
- (CONS
- (LIST 'MULTIPLE-VALUE-BIND (LIST |x| |k| |v|)
- (LIST |g|)
- (|bfLET1|
- (LIST 'CONS |k| (LIST 'CONS |v| 'NIL)) |e|))
- |localBindings|))))))))
+ (SETQ |localBindings|
+ (CONS (|bfTableIteratorBindingForm| |e| |x| |g|)
+ |localBindings|))))))
(SETQ |bfVar#2| (CDR |bfVar#2|))))
(LIST |inits| |localBindings| |exits|)))))
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index de9d71e3..12192b72 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -92,10 +92,9 @@
|s|))))
(DEFUN |shoeDictCons| ()
- (PROG (|d| |b| |a| |l|)
+ (PROG (|d| |b| |a|)
(RETURN
(PROGN
- (SETQ |l| (HKEYS |shoeKeyTable|))
(SETQ |d|
(PROGN
(SETQ |a| (MAKE-ARRAY 256))
@@ -107,34 +106,29 @@
(T (SETF (ELT |a| |i|) |b|)))
(SETQ |i| (+ |i| 1))))
|a|))
- (LET ((|bfVar#1| |l|) (|s| NIL))
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |s| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (|shoeInsert| |s| |d|)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (MULTIPLE-VALUE-BIND (#2=#:G720 |s| #:G721)
+ (#1#)
+ (COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
|d|))))
(DEFPARAMETER |shoeDict| (|shoeDictCons|))
(DEFUN |shoePunCons| ()
- (PROG (|a| |listing|)
+ (PROG (|a|)
(RETURN
(PROGN
- (SETQ |listing| (HKEYS |shoeKeyTable|))
(SETQ |a| (|makeBitVector| 256))
(LET ((|i| 0))
(LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
(SETQ |i| (+ |i| 1))))
- (LET ((|bfVar#1| |listing|) (|k| NIL))
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G722 |shoeKeyTable|)
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |k| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- ((|shoeStartsId| (ELT |k| 0)) NIL)
- (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (MULTIPLE-VALUE-BIND (#2=#:G723 |k| #:G724)
+ (#1#)
+ (COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL)
+ (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))))))
|a|))))
(DEFPARAMETER |shoePun| (|shoePunCons|))
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 12dda96a..22d6f918 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -760,28 +760,25 @@
(DEFUN |shoeReport| (|stream|)
(PROG (|b| |a|)
- (DECLARE (SPECIAL |$bootDefined| |$bootUsed| |$bootDefinedTwice|))
+ (DECLARE (SPECIAL |$bootDefined| |$bootDefinedTwice| |$bootUsed|))
(RETURN
(PROGN
(|shoeFileLine| "DEFINED and not USED" |stream|)
(SETQ |a|
- (LET ((|bfVar#2| NIL)
- (|bfVar#3| NIL)
- (|bfVar#1| (HKEYS |$bootDefined|))
- (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- (T
- (AND (NOT (|tableValue| |$bootUsed| |i|))
- (COND
- ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS |i| NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #1#)
- (SETQ |bfVar#3| (CDR |bfVar#3|)))))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G732 |$bootDefined|)
+ (LET ((|bfVar#1| NIL) (|bfVar#2| NIL))
+ (LOOP
+ (MULTIPLE-VALUE-BIND (#2=#:G733 |i| |b|)
+ (#1#)
+ (COND ((NOT #2#) (RETURN |bfVar#1|))
+ (T
+ (AND (NOT |b|)
+ (COND
+ ((NULL |bfVar#1|)
+ (SETQ |bfVar#1| #3=(CONS |i| NIL))
+ (SETQ |bfVar#2| |bfVar#1|))
+ (T (RPLACD |bfVar#2| #3#)
+ (SETQ |bfVar#2| (CDR |bfVar#2|))))))))))))
(|bootOut| (SSORT |a|) |stream|)
(|shoeFileLine| " " |stream|)
(|shoeFileLine| "DEFINED TWICE" |stream|)
@@ -789,32 +786,29 @@
(|shoeFileLine| " " |stream|)
(|shoeFileLine| "USED and not DEFINED" |stream|)
(SETQ |a|
- (LET ((|bfVar#5| NIL)
- (|bfVar#6| NIL)
- (|bfVar#4| (HKEYS |$bootUsed|))
- (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#4|))
- (PROGN (SETQ |i| (CAR |bfVar#4|)) NIL))
- (RETURN |bfVar#5|))
- (T
- (AND (NOT (|tableValue| |$bootDefined| |i|))
- (COND
- ((NULL |bfVar#5|) (SETQ |bfVar#5| #2=(CONS |i| NIL))
- (SETQ |bfVar#6| |bfVar#5|))
- (T (RPLACD |bfVar#6| #2#)
- (SETQ |bfVar#6| (CDR |bfVar#6|)))))))
- (SETQ |bfVar#4| (CDR |bfVar#4|)))))
- (LET ((|bfVar#7| (SSORT |a|)) (|i| NIL))
+ (WITH-HASH-TABLE-ITERATOR (#4=#:G734 |$bootUsed|)
+ (LET ((|bfVar#3| NIL) (|bfVar#4| NIL))
+ (LOOP
+ (MULTIPLE-VALUE-BIND (#5=#:G735 |i| |b|)
+ (#4#)
+ (COND ((NOT #5#) (RETURN |bfVar#3|))
+ (T
+ (AND (NOT |b|)
+ (COND
+ ((NULL |bfVar#3|)
+ (SETQ |bfVar#3| #6=(CONS |i| NIL))
+ (SETQ |bfVar#4| |bfVar#3|))
+ (T (RPLACD |bfVar#4| #6#)
+ (SETQ |bfVar#4| (CDR |bfVar#4|))))))))))))
+ (LET ((|bfVar#5| (SSORT |a|)) (|i| NIL))
(LOOP
(COND
- ((OR (NOT (CONSP |bfVar#7|)) (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL))
+ ((OR (NOT (CONSP |bfVar#5|)) (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL))
(RETURN NIL))
(T (SETQ |b| (CONCAT (PNAME |i|) " is used in "))
(|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream|
|b|)))
- (SETQ |bfVar#7| (CDR |bfVar#7|))))))))
+ (SETQ |bfVar#5| (CDR |bfVar#5|))))))))
(DEFUN |shoeDefUse| (|s|)
(LOOP
@@ -1047,16 +1041,28 @@
(RETURN
(PROGN
(|shoeFileLine| "USED and where DEFINED" |stream|)
- (SETQ |c| (SSORT (HKEYS |$bootUsed|)))
- (LET ((|bfVar#1| |c|) (|i| NIL))
+ (SETQ |c|
+ (SSORT
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G738 |$bootUsed|)
+ (LET ((|bfVar#1| NIL) (|bfVar#2| NIL))
+ (LOOP
+ (MULTIPLE-VALUE-BIND (#2=#:G739 |k| #:G740)
+ (#1#)
+ (COND ((NOT #2#) (RETURN |bfVar#1|))
+ ((NULL |bfVar#1|)
+ (SETQ |bfVar#1| #3=(CONS |k| NIL))
+ (SETQ |bfVar#2| |bfVar#1|))
+ (T (RPLACD |bfVar#2| #3#)
+ (SETQ |bfVar#2| (CDR |bfVar#2|))))))))))
+ (LET ((|bfVar#3| |c|) (|i| NIL))
(LOOP
(COND
- ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ ((OR (NOT (CONSP |bfVar#3|)) (PROGN (SETQ |i| (CAR |bfVar#3|)) NIL))
(RETURN NIL))
(T (SETQ |a| (CONCAT (PNAME |i|) " is used in "))
(|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream|
|a|)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
+ (SETQ |bfVar#3| (CDR |bfVar#3|))))))))
(DEFUN |shoeItem| (|str|)
(PROG (|dq|)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-12 21:40:14 +0000