forked from wtakuo/tscheme
-
Notifications
You must be signed in to change notification settings - Fork 0
/
init0.scm
74 lines (74 loc) · 9.85 KB
/
init0.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
(DEFINE SCHEME-IMPLEMENTATION-TYPE (LAMBDA () (QUOTE TSCHEME)))
(DEFINE SCHEME-IMPLEMENTATION-VERSION (LAMBDA () "Apr. 18, 2013"))
(DEFINE CAAR (LAMBDA (X) (CAR (CAR X))))
(DEFINE CADR (LAMBDA (X) (CAR (CDR X))))
(DEFINE CDAR (LAMBDA (X) (CDR (CAR X))))
(DEFINE CDDR (LAMBDA (X) (CDR (CDR X))))
(DEFINE CAAAR (LAMBDA (X) (CAR (CAAR X))))
(DEFINE CAADR (LAMBDA (X) (CAR (CADR X))))
(DEFINE CADAR (LAMBDA (X) (CAR (CDAR X))))
(DEFINE CADDR (LAMBDA (X) (CAR (CDDR X))))
(DEFINE CDAAR (LAMBDA (X) (CDR (CAAR X))))
(DEFINE CDADR (LAMBDA (X) (CDR (CADR X))))
(DEFINE CDDAR (LAMBDA (X) (CDR (CDAR X))))
(DEFINE CDDDR (LAMBDA (X) (CDR (CDDR X))))
(DEFINE CAAAAR (LAMBDA (X) (CAR (CAAAR X))))
(DEFINE CAAADR (LAMBDA (X) (CAR (CAADR X))))
(DEFINE CAADAR (LAMBDA (X) (CAR (CADAR X))))
(DEFINE CAADDR (LAMBDA (X) (CAR (CADDR X))))
(DEFINE CADAAR (LAMBDA (X) (CAR (CDAAR X))))
(DEFINE CADADR (LAMBDA (X) (CAR (CDADR X))))
(DEFINE CADDAR (LAMBDA (X) (CAR (CDDAR X))))
(DEFINE CADDDR (LAMBDA (X) (CAR (CDDDR X))))
(DEFINE CDAAAR (LAMBDA (X) (CDR (CAAAR X))))
(DEFINE CDAADR (LAMBDA (X) (CDR (CAADR X))))
(DEFINE CDADAR (LAMBDA (X) (CDR (CADAR X))))
(DEFINE CDADDR (LAMBDA (X) (CDR (CADDR X))))
(DEFINE CDDAAR (LAMBDA (X) (CDR (CDAAR X))))
(DEFINE CDDADR (LAMBDA (X) (CDR (CDADR X))))
(DEFINE CDDDAR (LAMBDA (X) (CDR (CDDAR X))))
(DEFINE CDDDDR (LAMBDA (X) (CDR (CDDDR X))))
(DEFINE FIRST CAR)
(DEFINE SECOND CADR)
(DEFINE THIRD CADDR)
(DEFINE FOURTH CADDDR)
(DEFINE FIFTH (LAMBDA (X) (CAR (CDDDDR X))))
(DEFINE SIXTH (LAMBDA (X) (CADR (CDDDDR X))))
(DEFINE SEVENTH (LAMBDA (X) (CADDR (CDDDDR X))))
(DEFINE EIGHTH (LAMBDA (X) (CADDDR (CDDDDR X))))
(DEFINE NTH (LAMBDA (L N) (IF (PAIR? L) (IF (< N 1) (CAR L) (NTH (CDR L) (-1+ N))) (ERROR "nth: invalid argument"))))
(DEFINE EQUAL? (LAMBDA (X Y) (COND ((EQ? X Y)) ((AND (PAIR? X) (PAIR? Y) (EQUAL? (CAR X) (CAR Y)) (EQUAL? (CDR X) (CDR Y)))) (ELSE #f))))
(DEFINE ASSOC (LAMBDA (KEY ALIST) (COND ((NULL? ALIST) #f) ((EQ? KEY (CAAR ALIST)) (CAR ALIST)) (ELSE (ASSOC KEY (CDR ALIST))))))
(DEFINE VECTOR? (LAMBDA (X) #f))
(DEFINE ATOM? (LAMBDA (X) (NOT (PAIR? X))))
(DEFINE APPEND (LAMBDA ARGS (LETREC ((APPEND2 (LAMBDA (XS YS) (IF (NULL? XS) YS (CONS (CAR XS) (APPEND2 (CDR XS) YS)))))) (LETREC ((LOOP (LAMBDA (ARGS) (IF (NULL? ARGS) (QUOTE ()) (APPEND2 (CAR ARGS) (LOOP (CDR ARGS))))))) (LOOP ARGS)))))
(DEFINE REVERSE (LAMBDA (L) (LETREC ((REV1 (LAMBDA (L A) (IF (NULL? L) A (REV1 (CDR L) (CONS (CAR L) A)))))) (REV1 L (QUOTE ())))))
(DEFINE LIST* (LAMBDA ARGS (IF (NULL? ARGS) (QUOTE ()) (APPEND (BUTLAST ARGS) (LAST ARGS)))))
(DEFINE BUTLAST (LAMBDA (L) (COND ((NULL? L) (ERROR "butlast")) ((NULL? (CDR L)) (QUOTE ())) (ELSE (CONS (CAR L) (BUTLAST (CDR L)))))))
(DEFINE LAST (LAMBDA (L) (COND ((NULL? L) (ERROR "last")) ((NULL? (CDR L)) (CAR L)) (ELSE (LAST (CDR L))))))
(DEFINE MAP1 (LAMBDA (F XS) (IF (NULL? XS) (QUOTE ()) (CONS (F (CAR XS)) (MAP1 F (CDR XS))))))
(DEFINE MAP (LAMBDA (F . ARGS) (IF (NULL? (CAR ARGS)) (QUOTE ()) (LET ((ARGS1 (MAP1 CAR ARGS)) (ARGSR (MAP1 CDR ARGS))) (CONS (APPLY F ARGS1) (APPLY MAP F ARGSR))))))
(DEFINE EXPAND-QUASIQUOTE (LAMBDA (E) (COND ((AND (ATOM? E) (NOT (SYMBOL? E))) E) ((SYMBOL? E) (LIST (QUOTE QUOTE) E)) (ELSE (LETREC ((LOOP (LAMBDA (L A B) (COND ((NULL? L) (CONS (QUOTE APPEND) (REVERSE (CONS (CONS (QUOTE LIST) (REVERSE B)) A)))) (ELSE (IF (PAIR? (CAR L)) (CASE (CAAR L) ((UNQUOTE) (LOOP (CDR L) A (CONS (CADAR L) B))) ((UNQUOTE-SPLICING) (LOOP (CDR L) (CONS (CADAR L) (CONS (CONS (QUOTE LIST) (REVERSE B)) A)) (QUOTE ()))) (ELSE (LOOP (CDR L) A (CONS (EXPAND-QUASIQUOTE (CAR L)) B)))) (LOOP (CDR L) A (CONS (EXPAND-QUASIQUOTE (CAR L)) B)))))))) (LOOP E (QUOTE ()) (QUOTE ())))))))
(DEFINE CALL-WITH-INPUT-FILE (LAMBDA (INFILE F) (LET ((INPORT (OPEN-INPUT-FILE INFILE))) (F INPORT) (CLOSE-INPUT-PORT INPORT))))
(DEFINE CALL-WITH-OUTPUT-FILE (LAMBDA (OUTFILE F) (LET ((OUTPORT (OPEN-OUTPUT-FILE OUTFILE))) (F OUTPORT) (CLOSE-OUTPUT-PORT OUTPORT))))
(DEFINE GENTEMP (LET ((*GENTEMP-COUNTER* 0)) (LAMBDA () (LET ((S (STRING->SYMBOL (STRING-APPEND "SCM:" (NUMBER->STRING *GENTEMP-COUNTER*))))) (SET! *GENTEMP-COUNTER* (+ *GENTEMP-COUNTER* 1)) S))))
(DEFINE *PROMPT* "> ")
(DEFINE *DEFAULT-PROMPT* "> ")
(DEFINE SYS:PROMPT-AND-READ (LAMBDA ARGS (DISPLAY (IF (NULL? ARGS) *DEFAULT-PROMPT* (CAR ARGS))) (READ)))
(DEFINE SYS:TOPLEVEL (LAMBDA () (DISPLAY *PROMPT*) (LET ((INPUT (READ))) (COND ((OR (EOF-OBJECT? INPUT) (EQ? INPUT (QUOTE BYE))) (DISPLAY "Bye!") (NEWLINE)) (ELSE (WRITE (SYS:EVAL (SYS:SIMPLIFY INPUT) (QUOTE ()))) (NEWLINE) (SYS:TOPLEVEL))))))
(DEFINE LOAD (LAMBDA (FILE) (CALL-WITH-INPUT-FILE FILE (LAMBDA (INPORT) (DISPLAY "Loading ") (WRITE FILE) (DISPLAY " ... ") (LETREC ((LOOP (LAMBDA (E) (IF (EOF-OBJECT? E) (BEGIN (DISPLAY "done.") (NEWLINE)) (BEGIN (SYS:EVAL (SYS:SIMPLIFY E) (QUOTE ())) (LOOP (READ INPORT))))))) (LOOP (READ INPORT)))))))
(DEFINE EVAL (LAMBDA (X) (SYS:EVAL (SYS:SIMPLIFY X) (QUOTE ()))))
(DEFINE MAP1 (LAMBDA (F XS) (IF (NULL? XS) (QUOTE ()) (CONS (F (CAR XS)) (MAP1 F (CDR XS))))))
(DEFINE LIST* (LAMBDA ARGS (IF (NULL? ARGS) (QUOTE ()) (APPEND (BUTLAST ARGS) (LAST ARGS)))))
(DEFINE BUTLAST (LAMBDA (L) (COND ((NULL? L) (ERROR "butlast")) ((NULL? (CDR L)) (QUOTE ())) (ELSE (CONS (CAR L) (BUTLAST (CDR L)))))))
(DEFINE LAST (LAMBDA (L) (COND ((NULL? L) (ERROR "last")) ((NULL? (CDR L)) (CAR L)) (ELSE (LAST (CDR L))))))
(DEFINE SYS:SIMPLIFY (LAMBDA (EXP) (COND ((BOOLEAN? EXP) EXP) ((NUMBER? EXP) EXP) ((CHAR? EXP) EXP) ((STRING? EXP) EXP) ((SYMBOL? EXP) EXP) ((PAIR? EXP) (LET ((OP (CAR EXP)) (ARGS (CDR EXP))) (COND ((EQ? OP (QUOTE QUOTE)) EXP) ((EQ? OP (QUOTE LAMBDA)) (LIST* (QUOTE LAMBDA) (CAR ARGS) (SYS:SIMPLIFY-BODY (CDR ARGS)))) ((EQ? OP (QUOTE LET)) (IF (SYMBOL? (CAR ARGS)) (LIST (QUOTE LETREC) (LIST (LIST (CAR ARGS) (LIST* (QUOTE LAMBDA) (SYS:LET-VARS (CADR ARGS)) (SYS:SIMPLIFY-BODY (CDDR ARGS))))) (LIST* (CAR ARGS) (MAP1 SYS:SIMPLIFY (SYS:LET-EXPS (CADR ARGS))))) (LIST* (QUOTE LET) (SYS:SIMPLIFY-LET-BSPECS (CAR ARGS)) (SYS:SIMPLIFY-BODY (CDR ARGS))))) ((EQ? OP (QUOTE LET*)) (SYS:SIMPLIFY-LET* (CAR ARGS) (CDR ARGS))) ((EQ? OP (QUOTE LETREC)) (LIST* (QUOTE LETREC) (SYS:SIMPLIFY-LET-BSPECS (CAR ARGS)) (SYS:SIMPLIFY-BODY (CDR ARGS)))) ((EQ? OP (QUOTE IF)) (LIST* (QUOTE IF) (MAP1 SYS:SIMPLIFY ARGS))) ((EQ? OP (QUOTE COND)) (LIST* (QUOTE COND) (MAP1 (LAMBDA (CLAUSE) (LIST* (IF (EQ? (CAR CLAUSE) (QUOTE ELSE)) (QUOTE ELSE) (SYS:SIMPLIFY (CAR CLAUSE))) (MAP1 SYS:SIMPLIFY (CDR CLAUSE)))) ARGS))) ((EQ? OP (QUOTE CASE)) (LIST* (QUOTE CASE) (SYS:SIMPLIFY (CAR ARGS)) (MAP1 (LAMBDA (CLAUSE) (LIST* (CAR CLAUSE) (MAP1 SYS:SIMPLIFY (CDR CLAUSE)))) (CDR ARGS)))) ((EQ? OP (QUOTE AND)) (LIST* (QUOTE AND) (MAP1 SYS:SIMPLIFY ARGS))) ((EQ? OP (QUOTE OR)) (LIST* (QUOTE OR) (MAP1 SYS:SIMPLIFY ARGS))) ((EQ? OP (QUOTE DO))) ((EQ? OP (QUOTE BEGIN)) (LIST* (QUOTE BEGIN) (SYS:SIMPLIFY-BODY ARGS))) ((EQ? OP (QUOTE SET!)) (LIST (QUOTE SET!) (CAR ARGS) (SYS:SIMPLIFY (CADR ARGS)))) ((EQ? OP (QUOTE DEFINE)) (IF (PAIR? (CAR ARGS)) (LIST (QUOTE DEFINE) (CAAR ARGS) (LIST* (QUOTE LAMBDA) (CDAR ARGS) (SYS:SIMPLIFY-BODY (CDR ARGS)))) (LIST (QUOTE DEFINE) (CAR ARGS) (SYS:SIMPLIFY (CADR ARGS))))) ((EQ? OP (QUOTE QUASIQUOTE)) (SYS:EXPAND-QUASIQUOTE (CAR ARGS))) (ELSE (MAP1 SYS:SIMPLIFY EXP))))) (ELSE (ERROR "Unknown expression type.")))))
(DEFINE SYS:SIMPLIFY-LET-BSPECS (LAMBDA (BSPECS) (MAP1 (LAMBDA (BSPEC) (LIST (CAR BSPEC) (SYS:SIMPLIFY (CADR BSPEC)))) BSPECS)))
(DEFINE SYS:LET-VARS (LAMBDA (BSPECS) (MAP1 CAR BSPECS)))
(DEFINE SYS:LET-EXPS (LAMBDA (BSPECS) (MAP1 CADR BSPECS)))
(DEFINE SYS:SIMPLIFY-LET* (LAMBDA (BSPECS BODY) (IF (NULL? BSPECS) (SYS:SIMPLIFY-BODY BODY) (LIST* (QUOTE LET) (LIST (LIST (CAAR BSPECS) (SYS:SIMPLIFY (CADAR BSPECS)))) (IF (NULL? (CDR BSPECS)) (SYS:SIMPLIFY-BODY BODY) (LIST (SYS:SIMPLIFY-LET* (CDR BSPECS) BODY)))))))
(DEFINE SYS:SIMPLIFY-BODY (LAMBDA (BODY) (LETREC ((SYS:SIMPLIFY-BODY-DEFINE (LAMBDA (BODY BSPECS) (COND ((NULL? BODY) (QUOTE ())) ((AND (LIST? (CAR BODY)) (NOT (NULL? (CAR BODY))) (EQ? (CAR (CAR BODY)) (QUOTE DEFINE))) (LET ((VAR (IF (PAIR? (CADR (CAR BODY))) (CAADR (CAR BODY)) (CADR (CAR BODY)))) (EXP (IF (PAIR? (CADR (CAR BODY))) (LIST* (QUOTE LAMBDA) (CDADR (CAR BODY)) (SYS:SIMPLIFY-BODY (CDDR (CAR BODY)))) (SYS:SIMPLIFY (CADDR (CAR BODY)))))) (SYS:SIMPLIFY-BODY-DEFINE (CDR BODY) (CONS (LIST VAR EXP) BSPECS)))) (ELSE (IF (NULL? BSPECS) (SYS:SIMPLIFY-BODY-OTHERS BODY) (LIST (LIST* (QUOTE LETREC) (REVERSE BSPECS) (SYS:SIMPLIFY-BODY-OTHERS BODY)))))))) (SYS:SIMPLIFY-BODY-OTHERS (LAMBDA (BODY) (COND ((NULL? BODY) (QUOTE ())) ((AND (LIST? (CAR BODY)) (NOT (NULL? (CAR BODY))) (EQ? (CAR (CAR BODY)) (QUOTE DEFINE))) (ERROR "Invalid local define.")) (ELSE (CONS (SYS:SIMPLIFY (CAR BODY)) (SYS:SIMPLIFY-BODY-OTHERS (CDR BODY)))))))) (SYS:SIMPLIFY-BODY-DEFINE BODY (QUOTE ())))))
(DEFINE SYS:EXPAND-QUASIQUOTE (LAMBDA (E) (COND ((AND (ATOM? E) (NOT (SYMBOL? E))) E) ((SYMBOL? E) (LIST (QUOTE QUOTE) E)) (ELSE (LETREC ((LOOP (LAMBDA (L A B) (COND ((NULL? L) (CONS (QUOTE APPEND) (REVERSE (CONS (CONS (QUOTE LIST) (REVERSE B)) A)))) (ELSE (IF (PAIR? (CAR L)) (CASE (CAAR L) ((UNQUOTE) (LOOP (CDR L) A (CONS (CADAR L) B))) ((UNQUOTE-SPLICING) (LOOP (CDR L) (CONS (CADAR L) (CONS (CONS (QUOTE LIST) (REVERSE B)) A)) (QUOTE ()))) (ELSE (LOOP (CDR L) A (CONS (SYS:EXPAND-QUASIQUOTE (CAR L)) B)))) (LOOP (CDR L) A (CONS (SYS:EXPAND-QUASIQUOTE (CAR L)) B)))))))) (LOOP E (QUOTE ()) (QUOTE ())))))))
(DEFINE SYS:SIMPLIFY-ALL (LAMBDA (INPORT OUTPORT) (LETREC ((LOOP (LAMBDA (E) (IF (NOT (EOF-OBJECT? E)) (BEGIN (WRITE (SYS:SIMPLIFY E) OUTPORT) (NEWLINE OUTPORT) (LOOP (READ INPORT))))))) (LOOP (READ INPORT)))))
(DEFINE SYS:SIMPLIFY-FILE (LAMBDA (INFILE OUTFILE) (CALL-WITH-INPUT-FILE INFILE (LAMBDA (INPORT) (CALL-WITH-OUTPUT-FILE OUTFILE (LAMBDA (OUTPORT) (SYS:SIMPLIFY-ALL INPORT OUTPORT)))))))
(DEFINE SYS:MAKE-INIT (LAMBDA (OUTFILE) (DISPLAY "Making ") (DISPLAY OUTFILE) (NEWLINE) (CALL-WITH-OUTPUT-FILE OUTFILE (LAMBDA (OUTPORT) (CALL-WITH-INPUT-FILE "init-src.scm" (LAMBDA (INPORT) (SYS:SIMPLIFY-ALL INPORT OUTPORT))) (CALL-WITH-INPUT-FILE "simplify.scm" (LAMBDA (INPORT) (SYS:SIMPLIFY-ALL INPORT OUTPORT)))))))