blob: 38951dd9033f309277973a5a54cd59646575e35e (
plain)
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
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
(PROCLAIM '(OPTIMIZE SPEED))
(IMPORT-MODULE "initial-env")
(IN-PACKAGE "BOOTTRAN")
(PROVIDE "utility")
(EXPORT '(|objectMember?| |symbolMember?| |stringMember?| |charMember?|
|scalarMember?| |listMember?| |reverse| |reverse!|
|lastNode| |append!| |copyList| |substitute| |substitute!|
|setDifference|))
(DEFUN |objectMember?| (|x| |l|)
(LOOP
(COND
((NULL |l|) (RETURN NIL))
((CONSP |l|)
(COND ((EQ |x| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
(T (RETURN (EQ |x| |l|))))))
(DEFUN |symbolMember?| (|s| |l|)
(LOOP
(COND
((NULL |l|) (RETURN NIL))
((CONSP |l|)
(COND ((EQ |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
(T (RETURN (EQ |s| |l|))))))
(DEFUN |stringMember?| (|s| |l|)
(LOOP
(COND
((NULL |l|) (RETURN NIL))
((CONSP |l|)
(COND
((STRING= |s| (CAR |l|)) (RETURN T))
(T (SETQ |l| (CDR |l|)))))
(T (RETURN (STRING= |s| |l|))))))
(DEFUN |charMember?| (|c| |l|)
(LOOP
(COND
((NULL |l|) (RETURN NIL))
((CONSP |l|)
(COND
((CHAR= |c| (CAR |l|)) (RETURN T))
(T (SETQ |l| (CDR |l|)))))
(T (RETURN (CHAR= |c| |l|))))))
(DEFUN |scalarMember?| (|s| |l|)
(LOOP
(COND
((NULL |l|) (RETURN NIL))
((CONSP |l|)
(COND
((EQL |s| (CAR |l|)) (RETURN T))
(T (SETQ |l| (CDR |l|)))))
(T (RETURN (EQL |s| |l|))))))
(DEFUN |listMember?| (|x| |l|)
(LOOP
(COND
((NULL |l|) (RETURN NIL))
((CONSP |l|)
(COND
((EQUAL |x| (CAR |l|)) (RETURN T))
(T (SETQ |l| (CDR |l|)))))
(T (RETURN (EQUAL |x| |l|))))))
(DEFUN |reverse| (|l|)
(PROG (|r|)
(RETURN
(PROGN
(SETQ |r| NIL)
(LOOP
(COND
((CONSP |l|) (SETQ |r| (CONS (CAR |l|) |r|))
(SETQ |l| (CDR |l|)))
(T (RETURN |r|))))))))
(DEFUN |reverse!| (|l|)
(PROG (|l2| |l1|)
(RETURN
(PROGN
(SETQ |l1| NIL)
(LOOP
(COND
((CONSP |l|) (SETQ |l2| (CDR |l|)) (RPLACD |l| |l1|)
(SETQ |l1| |l|) (SETQ |l| |l2|))
(T (RETURN |l1|))))))))
(DEFUN |lastNode| (|l|)
(PROG (|l'|)
(RETURN
(PROGN
(LOOP
(COND
((NOT (AND (CONSP |l|) (PROGN (SETQ |l'| (CDR |l|)) T)
(CONSP |l'|)))
(RETURN NIL))
(T (SETQ |l| |l'|))))
|l|))))
(DEFUN |copyList| (|l|)
(PROG (|l'| |t|)
(RETURN
(COND
((NOT (CONSP |l|)) |l|)
(T (SETQ |l'| (SETQ |t| (LIST (CAR |l|))))
(LOOP
(PROGN
(SETQ |l| (CDR |l|))
(COND
((CONSP |l|) (RPLACD |t| (LIST (CAR |l|)))
(SETQ |t| (CDR |t|)))
(T (RPLACD |t| |l|) (RETURN |l'|))))))))))
(DEFUN |append!| (|x| |y|)
(COND
((NULL |x|) |y|)
((NULL |y|) |x|)
(T (RPLACD (|lastNode| |x|) |y|) |x|)))
(DEFUN |substitute!| (|y| |x| |s|)
(COND
((NULL |s|) NIL)
((EQ |x| |s|) |y|)
(T (COND
((CONSP |s|) (RPLACA |s| (|substitute!| |y| |x| (CAR |s|)))
(RPLACD |s| (|substitute!| |y| |x| (CDR |s|)))))
|s|)))
(DEFUN |substitute| (|y| |x| |s|)
(PROG (|t| |h|)
(RETURN
(COND
((NULL |s|) NIL)
((EQ |x| |s|) |y|)
((CONSP |s|) (SETQ |h| (|substitute| |y| |x| (CAR |s|)))
(SETQ |t| (|substitute| |y| |x| (CDR |s|)))
(COND
((AND (EQ |h| (CAR |s|)) (EQ |t| (CDR |s|))) |s|)
(T (CONS |h| |t|))))
(T |s|)))))
(DEFUN |setDifference| (|x| |y|)
(PROG (|a| |l| |p|)
(RETURN
(COND
((NULL |x|) NIL)
((NULL |y|) |x|)
(T (SETQ |l| (SETQ |p| (LIST NIL)))
(LET ((|bfVar#1| |x|))
(LOOP
(COND
((ATOM |bfVar#1|) (RETURN NIL))
(T (AND (CONSP |bfVar#1|)
(PROGN (SETQ |a| (CAR |bfVar#1|)) T)
(NOT (|objectMember?| |a| |y|))
(PROGN
(RPLACD |p| (LIST |a|))
(SETQ |p| (CDR |p|))))))
(SETQ |bfVar#1| (CDR |bfVar#1|))))
(CDR |l|))))))
|
