1"======================================================================
2|
3|   Lisp interpreter written in Smalltalk
4|
5|
6 ======================================================================"
7
8
9"======================================================================
10|
11| Written by Aoki Atsushi and Nishihara Satoshi.
12| Modified by Paolo Bonzini (removed GUI and compiler for subset of Smalltalk).
13|
14| This file is part of GNU Smalltalk.
15|
16| GNU Smalltalk is free software; you can redistribute it and/or modify it
17| under the terms of the GNU General Public License as published by the Free
18| Software Foundation; either version 2, or (at your option) any later version.
19|
20| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
21| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
22| FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
23| details.
24|
25| You should have received a copy of the GNU General Public License along with
26| GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
27| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
28|
29 ======================================================================"
30
31SequenceableCollection subclass:  #LispList
32	instanceVariableNames: ''
33	classVariableNames: ''
34	poolDictionaries: ''
35	category: 'Examples-Lisp'!
36
37LispList subclass:  #LispCons
38	instanceVariableNames: 'head tail '
39	classVariableNames: 'VerticalLevel HorizontalLevel '
40	poolDictionaries: ''
41	category: 'Examples-Lisp'!
42
43LispList subclass:  #LispNil
44	instanceVariableNames: ''
45	classVariableNames: ''
46	poolDictionaries: ''
47	category: 'Examples-Lisp'!
48
49Object subclass:  #LispScanner
50	instanceVariableNames: 'source mark token tokenType failBlock '
51	classVariableNames: 'ScanningTable '
52	poolDictionaries: ''
53	category: 'Examples-Lisp'!
54
55LispScanner subclass:  #LispParser
56	instanceVariableNames: 'prevMark prevToken prevTokenType '
57	classVariableNames: ''
58	poolDictionaries: ''
59	category: 'Examples-Lisp'!
60
61Object subclass:  #LispTable
62	instanceVariableNames: 'properties '
63	classVariableNames: ''
64	poolDictionaries: ''
65	category: 'Examples-Lisp'!
66
67Object subclass:  #LispInterpreter
68	instanceVariableNames: 'lispTable bindStack failBlock textValue textCollector '
69	classVariableNames: ''
70	poolDictionaries: ''
71	category: 'Examples-Lisp'!
72
73
74
75!LispList class methodsFor: 'copyright'!
76
77copyright
78    ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'!
79
80system
81    ^'Goodies'!
82
83version
84    ^'003'! !
85
86!LispList class methodsFor: 'instance creation'!
87
88cell
89    ^self subclassResponsibility!
90
91head: headObject
92    ^self subclassResponsibility!
93
94head: headObject tail: tailObject
95    ^self subclassResponsibility!
96
97list: anArray
98    "LispCons list: #(1 2 3 4)"
99
100    | size list |
101    size := anArray size.
102    list := self null.
103    size
104	to: 1
105	by: -1
106	do: [:i | list := self head: (anArray at: i)
107			tail: list].
108    ^list!
109
110new: anInteger
111    "LispCons new: 5"
112
113    | newList |
114    newList := self null.
115    anInteger timesRepeat: [newList := self head: self null tail: newList].
116    ^newList!
117
118null
119    ^self subclassResponsibility!
120
121with: anObject
122    "LispCons with: 1"
123
124    ^self head: anObject!
125
126with: firstObject with: secondObject
127    "LispCons with: 1 with: 2"
128
129    ^self head: firstObject tail: (self with: secondObject)!
130
131with: firstObject with: secondObject with: thirdObject
132    "LispCons with: 1 with: 2 with: 3"
133
134    ^self head: firstObject tail: (self with: secondObject with: thirdObject)!
135
136with: firstObject with: secondObject with: thirdObject with: fourthObject
137    "LispCons with: 1 with: 2 with: 3 with: 4"
138
139    ^self head: firstObject tail: (self
140	    with: secondObject
141	    with: thirdObject
142	    with: fourthObject)! !
143
144!LispList methodsFor: 'accessing'!
145
146at: indexInteger put: anObject
147    ^self subscriptOutOfBoundsError: indexInteger!
148
149size
150    | tally |
151    tally := 0.
152    self do: [:each | tally := tally + 1].
153    ^tally! !
154
155!LispList methodsFor: 'private'!
156
157subscriptOutOfBoundsError: index
158    ^self error: 'subscript out of bounds: ' , index printString! !
159
160!LispList methodsFor: 'testing'!
161
162isCons
163    ^self null not!
164
165null
166    ^false! !
167
168
169
170!LispCons class methodsFor: 'class initialization'!
171
172initialize
173    "LispCons initialize."
174
175    HorizontalLevel := VerticalLevel := nil! !
176
177!LispCons class methodsFor: 'copyright'!
178
179copyright
180    ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'!
181
182system
183    ^'Goodies'!
184
185version
186    ^'003'! !
187
188!LispCons class methodsFor: 'examples'!
189
190example1
191    "LispCons example1."
192
193    | list |
194    list := LispCons list: #(1 2 3 4 5 6 7 8 9 10 ).
195    Transcript nl; show: list printString.
196    ^list!
197
198example2
199    "LispCons example2."
200
201    | null list |
202    null := LispCons null.
203    list := LispCons list: #(1 2 ).
204    list := LispCons head: list tail: null.
205    list := LispCons head: list tail: null.
206    Transcript nl; show: list printString.
207    ^list!
208
209example3
210    "LispCons example3."
211
212    | x y z |
213    x := LispCons list: #(1 2 3 ).
214    y := LispCons list: #(4 5 6 ).
215    z := LispCons list: #(1 2 3 4 5 6 ).
216    Transcript nl; show: '(setq x ''(1 2 3)) => ' , x printString.
217    Transcript nl; show: '(setq y ''(4 5 6)) => ' , y printString.
218    Transcript nl; show: '(setq z ''(1 2 3 4 5 6)) => ' , z printString.
219    Transcript nl; show: '(append x y) => ' , (x append: y) printString.
220    Transcript nl; show: '(length z) => ' , z length printString.
221    Transcript nl; show: '(member 3 z) => ' , (z member: 3) printString.
222    Transcript nl; show: '(nth 4 z) => ' , (z nth: 4) printString.
223    ^z!
224
225example4
226    "LispCons example4."
227
228    | list |
229    list := LispCons list: #(1 2 ).
230    list := LispCons head: list tail: (LispCons list: #(3 4 )).
231    list := LispCons head: list tail: (LispCons list: #(5 6 )).
232    Transcript nl; show: list saveString.
233    ^list!
234
235example5
236    "LispCons example5."
237
238    | list |
239    list := LispCons loadFrom: '
240	    (PetriNet Aoki
241		(Place p1 p2 p3 p4 p5)
242		(Transition t1 t2 t3 t4 t5)
243		(InputFunction
244		    (t1 p1 p2 p3 p4 p5)
245		    (t2 . p4)
246		    (t3 . p5))
247		(OutputFunction
248		    (t1 p1 p2 p3 p4 p5)
249		    (t2 . p4)
250		    (t3 . p5))
251		(Marking {#(1 2 3 4 5)})))'.
252    Transcript nl; show: list saveString.
253    ^list!
254
255example6
256    "LispCons example6."
257
258    | list |
259    list := LispCons loadFrom: '(aaa bbb ccc)'.
260    Transcript nl; show: list saveString.
261    ^list!
262
263example7
264    "LispCons example7."
265
266    | list |
267    list := LispCons loadFrom: ' `(`(1 2 `3) . `4 ) '.
268    Transcript nl; show: list saveString.
269    ^list! !
270
271!LispCons class methodsFor: 'instance creation'!
272
273cell
274    ^super new head: self null tail: self null!
275
276head: headObject
277    ^super new head: headObject tail: self null!
278
279head: headObject tail: tailObject
280    ^super new head: headObject tail: tailObject!
281
282list: anArray
283    | size list |
284    size := anArray size.
285    list := self null.
286    size
287	to: 1
288	by: -1
289	do: [:i | list := self head: (anArray at: i)
290			tail: list].
291    ^list!
292
293loadFrom: aStream
294    "by nishis, 1998/04/19 07:51"
295
296    | list |
297    list := LispParser parse: aStream.
298    ^list!
299
300new
301    ^self cell!
302
303null
304    ^LispNil null! !
305
306!LispCons class methodsFor: 'level accessing'!
307
308horizontalLevel
309    HorizontalLevel isNil ifTrue: [HorizontalLevel := 50].
310    ^HorizontalLevel!
311
312horizontalLevel: anInteger
313    HorizontalLevel := anInteger!
314
315verticalLevel
316    VerticalLevel isNil ifTrue: [VerticalLevel := 10].
317    ^VerticalLevel!
318
319verticalLevel: anInteger
320    VerticalLevel := anInteger! !
321
322!LispCons class methodsFor: 'utilities'!
323
324classHierarchy: aClass
325    "LispCons classHierarchy: Number."
326
327    | theClass list |
328    aClass isMeta
329	ifTrue: [theClass := aClass soleInstance]
330	ifFalse: [theClass := aClass].
331    list := self subclassHierarchy: theClass.
332    (theClass allSuperclasses select: [:each | each isMeta not])
333	do: [:each | list := self head: each name tail: (self head: list tail: self null)].
334    ^list!
335
336subclassHierarchy: aClass
337    "LispCons subclassHierarchy: Number."
338
339    | theClass list collection sub |
340    aClass isMeta
341	ifTrue: [theClass := aClass soleInstance]
342	ifFalse: [theClass := aClass].
343    list := self null.
344    theClass subclasses isEmpty
345	ifFalse:
346	    [collection := SortedCollection sortBlock: [:x :y | x name > y name].
347	    collection addAll: (theClass subclasses select: [:each | each isMeta not]).
348	    collection
349		do:
350		    [:each |
351		    sub := self subclassHierarchy: each.
352		    list := self head: sub tail: list]].
353    ^self head: theClass name tail: list!
354
355superclassHierarchy: aClass
356    "LispCons superclassHierarchy: Number."
357
358    | theClass list |
359    aClass isMeta
360	ifTrue: [theClass := aClass soleInstance]
361	ifFalse: [theClass := aClass].
362    list := self head: theClass name tail: self null.
363    (theClass allSuperclasses select: [:each | each isMeta not])
364	do: [:each | list := self head: each name tail: (self head: list tail: self null)].
365    ^list! !
366
367!LispCons methodsFor: 'accessing'!
368
369at: indexInteger
370    | count |
371    count := 1.
372    self
373	mapcdr:
374	    [:cdr |
375	    indexInteger = count ifTrue: [^cdr head].
376	    count := count + 1].
377    ^self subscriptOutOfBoundsError: indexInteger!
378
379at: indexInteger put: anObject
380    | count |
381    count := 1.
382    self
383	mapcdr:
384	    [:cdr |
385	    indexInteger = count ifTrue: [^cdr head: anObject].
386	    count := count + 1].
387    ^self subscriptOutOfBoundsError: indexInteger!
388
389head
390    ^head!
391
392head: anObject
393    ^head := anObject!
394
395head: headObject tail: tailObject
396    self head: headObject.
397    self tail: tailObject!
398
399tail
400    ^tail!
401
402tail: anObject
403    ^tail := anObject! !
404
405!LispCons methodsFor: 'adding'!
406
407add: newObject
408    ^self nconc: (self class head: newObject tail: self class null)! !
409
410!LispCons methodsFor: 'enumerating'!
411
412collect: aBlock
413    | list result |
414    list := self.
415    result := self class null.
416    [list isKindOf: self class]
417	whileTrue:
418	    [result := self class head: (aBlock value: list head)
419			tail: result.
420	    list := list tail].
421    ^result reverse!
422
423do: aBlock
424    | list |
425    list := self.
426    [list isKindOf: self class]
427	whileTrue:
428	    [aBlock value: list head.
429	    list := list tail]! !
430
431!LispCons methodsFor: 'functions'!
432
433append: list
434    (tail isKindOf: self class)
435	ifFalse: [^self class head: head tail: list].
436    ^self class head: head tail: (tail append: list)!
437
438last
439    | list |
440    list := self class head: nil tail: self.
441    self do: [:each | list := list tail].
442    ^list!
443
444length
445    | count |
446    count := 0.
447    self do: [:each | count := count + 1].
448    ^count!
449
450mapcdr: aBlock
451    | list |
452    list := self.
453    [list isKindOf: self class]
454	whileTrue:
455	    [aBlock value: list.
456	    list := list tail]!
457
458member: anObject
459    | list |
460    list := self.
461    self do:
462	[:each |
463	each = anObject ifTrue: [^list].
464	list := list tail].
465    ^self species null!
466
467memq: anObject
468    | list |
469    list := self.
470    self do:
471	[:each |
472	each == anObject ifTrue: [^list].
473	list := list tail].
474    ^self species null!
475
476nconc: list
477    self last rplacd: list!
478
479nth: nth
480    | count list |
481    nth <= 0 ifTrue: [^self species null].
482    count := 1.
483    list := self.
484    list do:
485	[:each |
486	count >= nth ifTrue: [^each].
487	count := count + 1].
488    ^self species null!
489
490reverse
491    | list |
492    list := self class null.
493    self do: [:each | list := self class head: each tail: list].
494    ^list!
495
496rplaca: anObject
497    self head: anObject!
498
499rplacd: anObject
500    self tail: anObject! !
501
502!LispCons methodsFor: 'pretty printing'!
503
504ppOn: aStream
505    self
506	ppOn: aStream
507	list: self
508	position: 0.
509    aStream nl!
510
511ppOn: aStream list: list position: position
512    (list isKindOf: self class)
513	ifFalse: [^self ppOn: aStream object: list].
514    (list head isKindOf: self class) not
515	ifTrue:
516	    [aStream nextPutAll: '('.
517	    self ppOn: aStream object: list head.
518	    (list tail isKindOf: LispList)
519		ifTrue: [self
520			ppOn: aStream
521			tail: list tail
522			position: position + 1]
523		ifFalse:
524		    [aStream nextPutAll: ' . '.
525		    self ppOn: aStream object: list tail].
526	    aStream nextPutAll: ')']
527	ifFalse:
528	    [aStream nextPutAll: '('.
529	    self
530		ppOn: aStream
531		list: list head
532		position: position + 1.
533	    (list tail isKindOf: self class)
534		ifTrue: [(list tail head isKindOf: self class)
535			ifTrue:
536			    [aStream nl.
537			    self ppOn: aStream spaceAndTab: position.
538			    self
539				ppOn: aStream
540				tail: list tail
541				position: position]
542			ifFalse:
543			    [self ppOn: aStream space: 1.
544			    self
545				ppOn: aStream
546				tail: list tail
547				position: position + 1]]
548		ifFalse: [(list tail isKindOf: LispList)
549			ifFalse:
550			    [aStream nextPutAll: ' . '.
551			    self ppOn: aStream object: list tail]].
552	    aStream nextPutAll: ')']!
553
554ppOn: aStream object: anObject
555    (anObject isKindOf: Symbol)
556	ifTrue: [^aStream nextPutAll: anObject asString].
557    (anObject isKindOf: String)
558	ifTrue:
559	    [aStream nextPutAll: '"'.
560	    anObject
561		do:
562		    [:char |
563		    char = $" ifTrue: [aStream nextPut: $"].
564		    aStream nextPut: char].
565	    ^aStream nextPutAll: '"'].
566    (anObject isKindOf: Number)
567	ifTrue: [^anObject storeOn: aStream].
568    (anObject isMemberOf: LispNil)
569	ifTrue: [^aStream nextPutAll: 'nil'].
570    aStream nextPutAll: '{'.
571    aStream nextPutAll: (anObject printString contractTo: 80).
572    aStream nextPutAll: '}'!
573
574ppOn: aStream space: anInteger
575    anInteger timesRepeat: [aStream nextPut: Character space]!
576
577ppOn: aStream spaceAndTab: anInteger
578    | tabs spaces |
579    tabs := anInteger // self tabStop.
580    spaces := anInteger \\ self tabStop.
581    tabs * (self tabStop // 4) timesRepeat: [aStream tab].
582    spaces timesRepeat: [aStream space]!
583
584ppOn: aStream tail: list position: position
585    list null ifTrue: [^self].
586    (list tail isKindOf: LispList)
587	ifTrue: [list tail null
588		ifTrue:
589		    [self ppOn: aStream space: 1.
590		    self
591			ppOn: aStream
592			list: list head
593			position: position + 1]
594		ifFalse:
595		    [self ppOn: aStream space: 1.
596		    self
597			ppOn: aStream
598			list: list head
599			position: position + 1.
600		    aStream nl.
601		    self ppOn: aStream spaceAndTab: position.
602		    self
603			ppOn: aStream
604			tail: list tail
605			position: position]]
606	ifFalse:
607	    [self ppOn: aStream space: 1.
608	    self
609		ppOn: aStream
610		list: list head
611		position: position + 1.
612	    aStream nextPutAll: ' . '.
613	    self ppOn: aStream object: list tail]!
614
615ppString
616    | stream |
617    stream := WriteStream on: (String new: 20).
618    self ppOn: stream.
619    ^stream contents! !
620
621!LispCons methodsFor: 'printing'!
622
623printOn: aStream
624    self printOn: aStream level: 0!
625
626printOn: aStream level: level
627    | verticalLevel |
628    verticalLevel := self class verticalLevel.
629    (verticalLevel ~= 0 and: [level >= verticalLevel])
630	ifTrue:
631	    [aStream nextPutAll: '( ... )'.
632	    ^self].
633    self null ifTrue: [^super printOn: aStream].
634    aStream nextPutAll: '('.
635    (head isKindOf: self class)
636	ifTrue: [head printOn: aStream level: level + 1]
637	ifFalse: [self printOn: aStream object: head].
638    (tail isKindOf: LispList)
639	ifTrue: [self
640		printOn: aStream
641		tail: tail
642		level: level]
643	ifFalse:
644	    [aStream nextPutAll: ' . '.
645	    self printOn: aStream object: tail.
646	    ^aStream nextPutAll: ')']!
647
648printOn: aStream object: anObject
649    (anObject isKindOf: Symbol)
650	ifTrue: [^aStream nextPutAll: anObject asString].
651    (anObject isKindOf: String)
652	ifTrue:
653	    [aStream nextPutAll: '"'.
654	    anObject
655		do:
656		    [:char |
657		    char = $" ifTrue: [aStream nextPut: $"].
658		    aStream nextPut: char].
659	    ^aStream nextPutAll: '"'].
660    (anObject isKindOf: Number)
661	ifTrue: [^anObject storeOn: aStream].
662    (anObject isMemberOf: LispNil)
663	ifTrue: [^aStream nextPutAll: 'nil'].
664    aStream nextPutAll: '{'.
665    aStream nextPutAll: (anObject printString contractTo: 80).
666    aStream nextPutAll: '}'!
667
668printOn: aStream tail: cdr level: level
669    | tailPart count horizontalLevel |
670    cdr null ifTrue: [^aStream nextPutAll: ')'].
671    tailPart := cdr.
672    count := 1.
673    horizontalLevel := self class horizontalLevel.
674    tailPart do:
675	[:each |
676	(horizontalLevel ~= 0 and: [count >= horizontalLevel])
677	    ifTrue:
678		[aStream nextPutAll: ' ... )'.
679		^self].
680	aStream nextPutAll: ' '.
681	(each isKindOf: self class)
682	    ifTrue: [tailPart head printOn: aStream level: level + 1]
683	    ifFalse: [self printOn: aStream object: each].
684	tailPart := tailPart tail.
685	count := count + 1].
686    (tailPart isKindOf: LispList)
687	ifTrue: [aStream nextPutAll: ')']
688	ifFalse:
689	    [aStream nextPutAll: ' . '.
690	    self printOn: aStream object: tailPart.
691	    aStream nextPutAll: ')']! !
692
693!LispCons methodsFor: 'private'!
694
695tabStop
696    ^8! !
697
698!LispCons methodsFor: 'saving'!
699
700saveOn: aStream
701    self
702	saveOn: aStream
703	list: self
704	position: 0.
705    aStream nl!
706
707saveOn: aStream list: list position: position
708    | location length |
709    (list isKindOf: self class)
710	ifFalse: [^self saveOn: aStream object: list].
711    (list head isKindOf: self class) not
712	ifTrue:
713	    [aStream nextPutAll: '('.
714	    location := aStream position.
715	    self saveOn: aStream object: list head.
716	    (list tail isKindOf: LispList)
717		ifTrue:
718		    [length := aStream position - location min: 40.
719		    length := 0.
720		    self
721			saveOn: aStream
722			tail: list tail
723			position: position + 1 + length]
724		ifFalse:
725		    [aStream nextPutAll: ' . '.
726		    self saveOn: aStream object: list tail].
727	    aStream nextPutAll: ')']
728	ifFalse:
729	    [aStream nextPutAll: '('.
730	    self
731		saveOn: aStream
732		list: list head
733		position: position + 1.
734	    (list tail isKindOf: self class)
735		ifTrue: [(list tail head isKindOf: self class)
736			ifTrue:
737			    [aStream nl.
738			    self saveOn: aStream spaceAndTab: position.
739			    self
740				saveOn: aStream
741				tail: list tail
742				position: position]
743			ifFalse:
744			    [self saveOn: aStream space: 1.
745			    self
746				saveOn: aStream
747				tail: list tail
748				position: position + 1]]
749		ifFalse: [(list tail isKindOf: LispList)
750			ifFalse:
751			    [aStream nextPutAll: ' . '.
752			    self saveOn: aStream object: list tail]].
753	    aStream nextPutAll: ')']!
754
755saveOn: aStream object: anObject
756    | string |
757    (anObject isKindOf: Symbol)
758	ifTrue: [^aStream nextPutAll: anObject asString].
759    (anObject isKindOf: String)
760	ifTrue:
761	    [aStream nextPutAll: '"'.
762	    anObject
763		do:
764		    [:char |
765		    char = $" ifTrue: [aStream nextPut: $"].
766		    aStream nextPut: char].
767	    ^aStream nextPutAll: '"'].
768    (anObject isKindOf: Integer)
769	ifTrue: [^anObject storeOn: aStream].
770    (anObject isKindOf: Float)
771	ifTrue: [^anObject storeOn: aStream].
772    "(anObject isKindOf: Double)
773	ifTrue: [^anObject storeOn: aStream]."
774    (anObject isMemberOf: LispNil)
775	ifTrue: [^aStream nextPutAll: 'nil'].
776    aStream nextPutAll: '{'.
777    ((anObject isKindOf: Point)
778	or: [anObject isKindOf: Rectangle])
779	ifTrue: [string := anObject printString]
780	ifFalse: [string := anObject storeString].
781    aStream nextPutAll: string.
782    aStream nextPutAll: '}'!
783
784saveOn: aStream space: anInteger
785    anInteger timesRepeat: [aStream nextPut: Character space]!
786
787saveOn: aStream spaceAndTab: anInteger
788    | tabs spaces |
789    tabs := anInteger // self tabStop.
790    spaces := anInteger \\ self tabStop.
791    tabs timesRepeat: [aStream tab].
792    spaces timesRepeat: [aStream space]!
793
794saveOn: aStream tail: list position: position
795    list null ifTrue: [^self].
796    (list tail isKindOf: LispList)
797	ifTrue: [list tail null
798		ifTrue:
799		    [self saveOn: aStream space: 1.
800		    self
801			saveOn: aStream
802			list: list head
803			position: position + 1]
804		ifFalse:
805		    [self saveOn: aStream space: 1.
806		    self
807			saveOn: aStream
808			list: list head
809			position: position + 1.
810		    aStream nl.
811		    self saveOn: aStream spaceAndTab: position.
812		    self
813			saveOn: aStream
814			tail: list tail
815			position: position]]
816	ifFalse:
817	    [self saveOn: aStream space: 1.
818	    self
819		saveOn: aStream
820		list: list head
821		position: position + 1.
822	    aStream nextPutAll: ' . '.
823	    self saveOn: aStream object: list tail]!
824
825saveString
826    | stream |
827    stream := WriteStream on: (String new: 20).
828    self saveOn: stream.
829    ^stream contents! !
830
831!LispCons methodsFor: 'testing'!
832
833= anObject
834    (anObject isKindOf: self class)
835	ifFalse: [^false].
836    self head = anObject head ifTrue: [^self tail = anObject tail].
837    ^false! !
838
839
840LispCons initialize!
841
842LispNil class instanceVariableNames: 'null '!
843
844!LispNil class methodsFor: 'class initialization'!
845
846initialize
847    "LispNil initialize."
848
849    self null! !
850
851!LispNil class methodsFor: 'copyright'!
852
853copyright
854    ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'!
855
856system
857    ^'Goodies'!
858
859version
860    ^'003'! !
861
862!LispNil class methodsFor: 'instance creation'!
863
864cell
865    ^LispCons cell!
866
867head: headObject
868    ^self shouldNotImplement!
869
870head: headObject tail: tailObject
871    ^self shouldNotImplement!
872
873new
874    ^self null!
875
876null
877    null isNil ifTrue: [null := super new].
878    ^null! !
879
880!LispNil methodsFor: 'accessing'!
881
882head
883    ^self!
884
885tail
886    ^self! !
887
888!LispNil methodsFor: 'adding'!
889
890add: newObject
891    ^self shouldNotImplement! !
892
893!LispNil methodsFor: 'enumerating'!
894
895do: aBlock
896    ^self! !
897
898!LispNil methodsFor: 'functions'!
899
900append: list
901    ^list!
902
903length
904    ^0!
905
906mapcdr: aBlock
907    ^self!
908
909member: anObject
910    ^self!
911
912nconc: list
913    ^list!
914
915nth: nth
916    ^self!
917
918reverse
919    ^self! !
920
921!LispNil methodsFor: 'pretty printing'!
922
923ppOn: aStream
924    aStream nextPutAll: 'nil'.
925    aStream nl!
926
927ppString
928    ^'nil\' withCRs! !
929
930!LispNil methodsFor: 'printing'!
931
932printOn: aStream
933    aStream nextPutAll: 'nil'! !
934
935!LispNil methodsFor: 'saving'!
936
937saveOn: aStream
938    aStream nextPutAll: 'nil'!
939
940saveString
941    ^'nil'! !
942
943!LispNil methodsFor: 'testing'!
944
945null
946    ^true! !
947
948
949LispNil initialize!
950
951!LispScanner class methodsFor: 'copyright'!
952
953copyright
954    ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'!
955
956system
957    ^'Goodies'!
958
959version
960    ^'003'! !
961
962!LispScanner class methodsFor: 'initialize-release'!
963
964initialize
965    | newTable |
966    newTable := Array new: 256 withAll: #xBinary.
967    newTable atAll: #(9 10 11 12 13 32) put: #xDelimiter.
968    newTable atAll: ($0 asInteger to: $9 asInteger) put: #xDigit.
969    newTable atAll: ($A asInteger to: $Z asInteger) put: #xSymbol.
970    newTable atAll: ($a asInteger to: $z asInteger) put: #xSymbol.
971    128 to: 256 do: [:i | newTable at: i put: #xSymbol].
972    newTable at: $' asInteger put: #quote.
973    newTable at: $" asInteger put: #xDoubleQuote.
974    newTable at: ${ asInteger put: #xBrace.
975    newTable at: $+ asInteger put: #xSign.
976    newTable at: $- asInteger put: #xSign.
977    newTable at: $< asInteger put: #xSymbol.
978    newTable at: $> asInteger put: #xSymbol.
979    newTable at: $= asInteger put: #xSymbol.
980    newTable at: $~ asInteger put: #xSymbol.
981    newTable at: $* asInteger put: #xSymbol.
982    newTable at: $/ asInteger put: #xSymbol.
983    newTable at: $_ asInteger put: #xSymbol.
984    newTable at: $: asInteger put: #xSymbol.
985    newTable at: $, asInteger put: #xSymbol.
986    newTable at: $\ asInteger put: #xSymbol.
987    newTable at: $% asInteger put: #xComment.
988    newTable at: $( asInteger put: #leftParenthesis.
989    newTable at: $) asInteger put: #rightParenthesis.
990    newTable at: $[ asInteger put: #leftParenthesis.
991    newTable at: $] asInteger put: #rightParenthesis.
992    newTable at: $. asInteger put: #period.
993    newTable at: $` asInteger put: #quote.
994    newTable at: $! asInteger put: #eof.
995    ScanningTable := newTable! !
996
997!LispScanner class methodsFor: 'instance creation'!
998
999new
1000    ^(super new) initScanner; yourself! !
1001
1002!LispScanner methodsFor: 'initialize-release'!
1003
1004initScanner
1005    failBlock :=
1006	[:errorMessage || label string |
1007	    label := errorMessage , ' near ' , (token printString contractTo: 10).
1008	    string := source upToEnd.
1009	    string isEmpty
1010		ifTrue: [string := '--> end of file']
1011		ifFalse: [string := '--> ' , (string contractTo: 30)].
1012	    self error: 'scan error   ', label, Character nl asString, string].
1013    !
1014
1015on: inputStream
1016    source := inputStream.
1017    mark := source position! !
1018
1019!LispScanner methodsFor: 'private'!
1020
1021nextChar
1022    | char |
1023    source atEnd ifTrue: [ ^$! ].
1024    char := source next.
1025    char = Character cr
1026	ifTrue:
1027	    [char := Character nl. source peekFor: char].
1028    ^char!
1029
1030peekChar
1031    | char |
1032    char := source peek.
1033    char = Character cr ifTrue: [char := Character nl].
1034    char isNil ifTrue: [char := $! ].
1035    ^char!
1036
1037unNextChar
1038    source skip: -1! !
1039
1040!LispScanner methodsFor: 'reading'!
1041
1042numberFrom: aStream
1043    ^Number readFrom: aStream!
1044
1045objectFrom: aStream
1046    "POSSIBLE PORTABILITY PROBLEM HERE!"
1047    | buffer char |
1048    buffer := WriteStream on: (String new: 20).
1049    char := aStream next.
1050
1051    [char := aStream next.
1052    char = $}]
1053	whileFalse:
1054	    [char == nil ifTrue: [^failBlock value: 'Syntax error unmatched ${'].
1055	    buffer nextPut: char].
1056    ^Behavior
1057	evaluate: buffer contents
1058	to: nil
1059	ifError: []!
1060
1061stringFrom: aStream
1062    | buffer char string |
1063    buffer := WriteStream on: (String new: 20).
1064    char := aStream next.
1065    char = $" ifTrue: [
1066	[char := aStream peek.
1067	char ~~ nil]
1068	    whileTrue:
1069		[char = $"
1070		    ifTrue:
1071			[aStream next.
1072			char := aStream peek.
1073			char = $" ifFalse: [^String fromString: buffer contents]].
1074		buffer nextPut: aStream next]].
1075    string := aStream upToEnd.
1076    string size > 100 ifTrue: [string := string copyFrom: 1 to: 100].
1077    ^failBlock value: 'Syntax error unmatched $'''!
1078
1079symbolFrom: aStream
1080    | buffer char type |
1081    buffer := WriteStream on: (String new: 20).
1082    char := aStream peek.
1083    [char notNil and: [(type := self tableAt: char) == #xSymbol or: [type == #xDigit or: [type == #xSign]]]]
1084	whileTrue:
1085	    [buffer nextPut: aStream next.
1086	    char := aStream peek].
1087    buffer contents = 'nil' ifTrue: [^LispNil null].
1088    ^Symbol intern: buffer contents! !
1089
1090!LispScanner methodsFor: 'scanning'!
1091
1092multiChar: type
1093    self perform: type!
1094
1095nextToken
1096    | char |
1097    mark := source position.
1098    char := self peekChar.
1099    tokenType := self tableAt: char.
1100    [tokenType == #xDelimiter]
1101	whileTrue:
1102	    [self nextChar.
1103	    char := self peekChar.
1104	    tokenType := self tableAt: char].
1105    (tokenType at: 1) = $x
1106	ifTrue: [self multiChar: tokenType]
1107	ifFalse: [self singleChar: tokenType].
1108    ^token!
1109
1110singleChar: type
1111    self nextChar.
1112    token := type!
1113
1114tableAt: char
1115    | index |
1116    index := char asInteger.
1117    ^index = 0
1118	ifFalse: [ScanningTable at: index]
1119	ifTrue: [#xBinary]!
1120
1121unNextToken
1122    source position: mark! !
1123
1124!LispScanner methodsFor: 'x'!
1125
1126xBinary
1127    ^failBlock value: 'Syntax error ' , source peek printString!
1128
1129xBrace
1130    tokenType := #object.
1131    token := self objectFrom: source!
1132
1133xComment
1134    | char |
1135    [(char := self nextChar) = Character nl]
1136	whileFalse: [char == nil ifTrue: [^self nextToken]].
1137    ^self nextToken!
1138
1139xDigit
1140    tokenType := #number.
1141    token := self numberFrom: source!
1142
1143xDoubleQuote
1144    tokenType := #string.
1145    token := self stringFrom: source!
1146
1147xSign
1148    | char sign |
1149    sign := self nextChar.
1150    char := self peekChar.
1151    char isDigit
1152	ifTrue:
1153	    [tokenType := #number.
1154	    token := self numberFrom: source.
1155	    sign == $- ifTrue: [token := token negated]]
1156	ifFalse:
1157	    [self unNextChar.
1158	    tokenType := #symbol.
1159	    token := self symbolFrom: source]!
1160
1161xSymbol
1162    tokenType := #symbol.
1163    token := self symbolFrom: source! !
1164
1165
1166LispScanner initialize!
1167
1168!LispParser class methodsFor: 'copyright'!
1169
1170copyright
1171    ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'!
1172
1173system
1174    ^'Goodies'!
1175
1176version
1177    ^'003'! !
1178
1179!LispParser class methodsFor: 'examples'!
1180
1181example1
1182    "LispParser example1."
1183
1184    | list |
1185    list := LispParser parse: '(1 2 3 4 (5 6 7 8 9) 10)'.
1186    ^list!
1187
1188example2
1189    "LispParser example2."
1190
1191    | list |
1192    list := LispParser parse: '
1193	    (10 (1 2)
1194	     20 (3 4 . 100)
1195	     30 (5 6) . 200)
1196    '.
1197    ^list!
1198
1199example3
1200    "LispParser example3."
1201
1202    | list |
1203    list := LispParser parse: '
1204	    (PetriNet Aoki
1205		(Place
1206		    (p1 . {100@100})
1207		    (p2 . {200@200})
1208		    (p3 . {300@300})
1209		    (p4 . {400@400})
1210		    (p5 . {500@500}))
1211		(Transition
1212		    (t1 . {100@100})
1213		    (t2 . {200@200})
1214		    (t3 . {300@300})
1215		    (t4 . {400@400})
1216		    (t5 . {500@500}))
1217		(InputFunction
1218		    (t1 p1 p2 p3 p4 p5)
1219		    (t2 . p4)
1220		    (t3 . p5))
1221		(OutputFunction
1222		    (t1 p1 p2 p3 p4 p5)
1223		    (t2 . p4)
1224		    (t3 . p5))
1225		(Marking {#(1 2 3 4 5)}))'.
1226    Transcript nl; show: list saveString.
1227    list := LispParser parse: list saveString.
1228    ^list!
1229
1230example4
1231    "LispParser example4."
1232
1233    | list |
1234    list := LispParser parse: '(1 2 3 4 (5 6 7 ~ 8 9) 10)'.
1235    ^list!
1236
1237example5
1238    "LispParser example5."
1239
1240    | list |
1241    list := LispParser parse: '(1 2 3 4 (5 6 7 {100@100 8 9) 10)'.    "error"
1242    ^list!
1243
1244example6
1245    "LispParser example6."
1246
1247    | list |
1248    list := LispParser parse: '(1 2 3 4 (5 6 7 ''aaaaa 8 9) 10)'.
1249    ^list!
1250
1251example7
1252    "LispParser example7."
1253
1254    | list |
1255    list := LispParser parse: ' `(`(1 2 `3) . `4) '.    "`(`(1 2 `3) . `4) -> (quote ((quote (1 2 (quote 3))) quote 4))"
1256    ^list! !
1257
1258!LispParser class methodsFor: 'private'!
1259
1260makeStream: aStream
1261
1262    ^(aStream respondsTo: #next) "HACK"
1263	ifTrue: [aStream]
1264	ifFalse: [ReadStream on: aStream asString].! !
1265
1266!LispParser class methodsFor: 'utilities'!
1267
1268parse: aStream
1269    ^self new parse: (self makeStream: aStream)!
1270
1271parse: aStream ifFail: aBlock
1272    ^self new parse: (self makeStream: aStream)
1273	ifFail: aBlock! !
1274
1275!LispParser methodsFor: 'parsing'!
1276
1277parse: sourceStream
1278    | label string |
1279    ^self parse: sourceStream
1280	ifFail:
1281	    [:errorMessage |
1282	    label := errorMessage , ' near ' , (token printString contractTo: 20).
1283	    string := source upToEnd.
1284	    string isEmpty
1285		ifTrue: [string := '--> end of file']
1286		ifFalse: [string := '--> ' , (string contractTo: 30)].
1287	    self error: 'parse error   ', label, Character nl asString, string.
1288	    ^LispNil null]!
1289
1290parse: sourceStream ifFail: aBlock
1291    | result |
1292    self init: sourceStream ifFail: aBlock.
1293    result := self scan.
1294    ^result! !
1295
1296!LispParser methodsFor: 'private'!
1297
1298init: sourceStream ifFail: aBlock
1299    super on: sourceStream.
1300    failBlock := aBlock! !
1301
1302!LispParser methodsFor: 'scan and parse'!
1303
1304scan
1305    source atEnd ifTrue: [^LispCons null].
1306    ^self scanList!
1307
1308scanList
1309    | expression |
1310    self nextToken.
1311    tokenType == #eof ifTrue: [^LispCons null].
1312    tokenType == #number ifTrue: [^token].
1313    tokenType == #string ifTrue: [^token].
1314    tokenType == #object ifTrue: [^token].
1315    tokenType == #symbol ifTrue: [^token].
1316    tokenType == #quote
1317	ifTrue:
1318	    [expression := LispCons head: self scanList tail: LispCons null.
1319	    ^LispCons head: #quote tail: expression].
1320    tokenType == #leftParenthesis ifTrue: [^self scanListAux].
1321    ^failBlock value: 'Syntax error'!
1322
1323scanListAux
1324    | cdr |
1325    self nextToken.
1326    tokenType == #eof ifTrue: [^LispCons null].
1327    tokenType == #rightParenthesis ifTrue: [^LispCons null].
1328    tokenType == #leftParenthesis ifTrue: [^LispCons head: self scanListAux tail: self scanListAux].
1329    tokenType == #number ifTrue: [^LispCons head: token tail: self scanListAux].
1330    tokenType == #string ifTrue: [^LispCons head: token tail: self scanListAux].
1331    tokenType == #object ifTrue: [^LispCons head: token tail: self scanListAux].
1332    tokenType == #symbol ifTrue: [^LispCons head: token tail: self scanListAux].
1333    tokenType == #period
1334	ifTrue:
1335	    [cdr := self scanList.
1336	    self nextToken.
1337	    tokenType == #rightParenthesis
1338		ifTrue: [^cdr]
1339		ifFalse: [^failBlock value: 'Syntax error']].
1340    tokenType == #quote
1341	ifTrue:
1342	    [cdr := LispCons head: self scanList tail: LispCons null.
1343	    cdr := LispCons head: #quote tail: cdr.
1344	    ^LispCons head: cdr tail: self scanListAux].
1345    self unNextToken.
1346    ^failBlock value: 'Syntax error'! !
1347
1348!LispParser methodsFor: 'scanning'!
1349
1350nextToken
1351    prevMark := mark.
1352    prevToken := token.
1353    prevTokenType := tokenType.
1354    ^super nextToken!
1355
1356unNextToken
1357    super unNextToken.
1358    mark := prevMark.
1359    token := prevToken.
1360    tokenType := prevTokenType! !
1361
1362
1363
1364!LispTable class methodsFor: 'copyright'!
1365
1366copyright
1367    ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'!
1368
1369system
1370    ^'Goodies'!
1371
1372version
1373    ^'003'! !
1374
1375!LispTable class methodsFor: 'instance creation'!
1376
1377new
1378    ^super new initialize! !
1379
1380!LispTable methodsFor: 'accessing'!
1381
1382at: symbol
1383    ^self getprop: symbol key: #apval!
1384
1385at: symbol put: value
1386    self intern: symbol.
1387    ^self
1388	putprop: symbol
1389	key: #apval
1390	value: value!
1391
1392identifiers
1393    ^properties keys asSortedCollection! !
1394
1395!LispTable methodsFor: 'adding'!
1396
1397add: symbol
1398    self intern: symbol! !
1399
1400!LispTable methodsFor: 'initialize-release'!
1401
1402initialize
1403    properties := Dictionary new! !
1404
1405!LispTable methodsFor: 'private'!
1406
1407errorSymbolNotFound
1408    self error: 'symbol not found'!
1409
1410intern: symbol
1411    (properties includesKey: symbol)
1412	ifFalse: [properties at: symbol put: Dictionary new].
1413    ^symbol! !
1414
1415!LispTable methodsFor: 'property access'!
1416
1417getprop: identifier key: key
1418    | property |
1419    property := properties at: identifier ifAbsent: [^self errorSymbolNotFound].
1420    ^property at: key ifAbsent: [^nil]!
1421
1422putprop: identifier key: key value: value
1423    | property |
1424    property := properties at: identifier ifAbsent: [^self errorSymbolNotFound].
1425    ^property at: key put: value!
1426
1427remprop: identifier key: key
1428    | property |
1429    property := properties at: identifier ifAbsent: [^self errorSymbolNotFound].
1430    ^property removeKey: key ifAbsent: [^nil]! !
1431
1432!LispTable methodsFor: 'removing'!
1433
1434remove: symbol
1435    ^properties removeKey: symbol ifAbsent: [^nil]! !
1436
1437
1438
1439!LispInterpreter class methodsFor: 'copyright'!
1440
1441copyright
1442    ^'Copyright (C) 1995-1998 AOKI Atsushi, All Rights Reserved.'!
1443
1444system
1445    ^'Goodies'!
1446
1447version
1448    ^'003'! !
1449
1450!LispInterpreter class methodsFor: 'examples'!
1451
1452example01
1453    "LispInterpreter example01."
1454
1455    | aList |
1456    aList := LispInterpreter evaluateFrom: '
1457
1458    nil
1459
1460    '.
1461    ^aList!
1462
1463example02
1464    "LispInterpreter example02."
1465
1466    | aList |
1467    aList := LispInterpreter evaluateFrom: '
1468
1469    123
1470
1471    '.
1472    ^aList!
1473
1474example03
1475    "LispInterpreter example03."
1476
1477    | aList |
1478    aList := LispInterpreter evaluateFrom: '
1479
1480    "abc"
1481
1482    '.
1483    ^aList!
1484
1485example04
1486    "LispInterpreter example04."
1487
1488    | aList |
1489    aList := LispInterpreter evaluateFrom: '
1490
1491    (cons 3 4)
1492
1493    '.
1494    ^aList!
1495
1496example05
1497    "LispInterpreter example05."
1498
1499    | aList |
1500    aList := LispInterpreter evaluateFrom: '
1501
1502    (quote (3 4))
1503
1504    '.
1505    ^aList!
1506
1507example06
1508    "LispInterpreter example06."
1509
1510    | aList |
1511    aList := LispInterpreter evaluateFrom: '
1512
1513    (car (quote (3 4)))
1514
1515    '.
1516    ^aList!
1517
1518example07
1519    "LispInterpreter example07."
1520
1521    | aList |
1522    aList := LispInterpreter evaluateFrom: '
1523
1524    (cdr (quote (3 4)))
1525
1526    '.
1527    ^aList!
1528
1529example08
1530    "LispInterpreter example08."
1531
1532    | aList |
1533    aList := LispInterpreter evaluateFrom: '
1534
1535    (cons (car `(1 2 3)) `(3 4))
1536
1537    '.
1538    ^aList!
1539
1540example09
1541    "LispInterpreter example09."
1542
1543    | aList |
1544    aList := LispInterpreter evaluateFrom: '
1545
1546    (+ 1 2 3 4 5 6 7 8 9 10)
1547
1548    '.
1549    ^aList!
1550
1551example10
1552    "LispInterpreter example10."
1553
1554    | aList |
1555    aList := LispInterpreter evaluateFrom: '
1556
1557    (progn
1558	(setq x 100)
1559	(setq y 200 z 300)
1560	(+ x y z))
1561
1562    '.
1563    ^aList!
1564
1565example11
1566    "LispInterpreter example11."
1567
1568    | aList |
1569    aList := LispInterpreter evaluateFrom: '
1570
1571    (progn
1572	(defun plus (x y) (+ x y))
1573	(plus 3 4))
1574
1575    '.
1576    ^aList!
1577
1578example12
1579    "LispInterpreter example12."
1580
1581    | aList |
1582    aList := LispInterpreter evaluateFrom: '
1583
1584    (progn
1585	(defun concat (x y)
1586	    (cond
1587		((atom x) y)
1588		(t (cons
1589			(car x)
1590			(concat (cdr x) y)))))
1591	(concat `(1 2 3) `(4 5)))
1592
1593    '.
1594    ^aList!
1595
1596example13
1597    "LispInterpreter example13."
1598
1599    | aList |
1600    aList := LispInterpreter evaluateFrom: '
1601
1602    (progn
1603	(defun plus nlambda (x) (plus1 x))
1604	(defun plus1 lambda (x)
1605	    (cond
1606		((null x) 0)
1607		(t (+ (car x) (plus1 (cdr x))))))
1608	(plus 1 2 3 4 5 6 7 8 9 10))
1609
1610    '.
1611    ^aList!
1612
1613example14
1614    "LispInterpreter example14."
1615
1616    | aList |
1617    aList := LispInterpreter evaluateFrom: '
1618
1619    ((lambda (x y) (cons x (cons y nil))) 3 4)
1620
1621    '.
1622    ^aList!
1623
1624example15
1625    "LispInterpreter example15."
1626
1627    | aList |
1628    aList := LispInterpreter evaluateFrom: '
1629
1630    ((nlambda (x) x) 1 2 3 4 5 6 7 8 9 10)
1631
1632    '.
1633    ^aList!
1634
1635example16
1636    "LispInterpreter example16."
1637
1638    | aList |
1639    aList := LispInterpreter evaluateFrom: '
1640
1641    (progn
1642	(setq x 100)
1643	(setq y 200)
1644	(do
1645	    (x y)
1646	    (setq x 10000)
1647	    (setq y 20000)
1648	    (send {Transcript} `nl)
1649	    (send {Transcript} `show: (send x `printString))
1650	    (send {Transcript} `nl)
1651	    (send {Transcript} `show: (send y `printString)))
1652	(send {Transcript} `nl)
1653	(send {Transcript} `show: (send x `printString))
1654	(send {Transcript} `nl)
1655	(send {Transcript} `show: (send y `printString)))
1656
1657    '.
1658    ^aList!
1659
1660example17
1661    "LispInterpreter example17."
1662
1663    | aList |
1664    aList := LispInterpreter evaluateFrom: '
1665
1666    (do
1667	(count)
1668	(setq count 1)
1669	(while
1670	    (<= count 100)
1671	    do
1672	    (send {Transcript} `nl)
1673	    (send {Transcript} `show: (send count `printString))
1674	    (setq count (+ count 1))))
1675
1676    '.
1677    ^aList!
1678
1679example18
1680    "LispInterpreter example18."
1681
1682    | aList |
1683    aList := LispInterpreter evaluateFrom: '
1684
1685    (do
1686	(count)
1687	(setq count 1)
1688	(repeat
1689	    (send {Transcript} `nl)
1690	    (send {Transcript} `show: (send count `printString))
1691	    (setq count (+ count 1))
1692	    until
1693	    (<= count 100)))
1694
1695    '.
1696    ^aList! !
1697
1698!LispInterpreter class methodsFor: 'instance creation'!
1699
1700new
1701    ^super new initialize! !
1702
1703!LispInterpreter class methodsFor: 'printing'!
1704
1705printString: anObject
1706    "LispInterpreter printString: 'string'."
1707    "LispInterpreter printString: #symbol."
1708    "LispInterpreter printString: 123."
1709    "LispInterpreter printString: 123.456."
1710    "LispInterpreter printString: 123.456e7."
1711    "LispInterpreter printString: LispNil null."
1712    "LispInterpreter printString: nil."
1713
1714    | aStream |
1715    aStream := WriteStream on: (String new: 32).
1716    (anObject isKindOf: LispCons)
1717	ifTrue: [anObject printOn: aStream level: 0]
1718	ifFalse: [LispCons new printOn: aStream object: anObject].
1719    ^aStream contents! !
1720
1721!LispInterpreter class methodsFor: 'public access'!
1722
1723evaluate: sExpression
1724    ^self new evaluateTopLevel: sExpression ifFail: [:errorMessage | self error: errorMessage]!
1725
1726evaluate: sExpression ifFail: aBlock
1727    ^self new evaluateTopLevel: sExpression ifFail: aBlock!
1728
1729evaluateFrom: aStream
1730    ^self new evaluateTopLevel: (LispParser parse: aStream)
1731	ifFail: [:errorMessage | self error: errorMessage]!
1732
1733evaluateFrom: aStream ifFail: aBlock
1734    ^self new evaluateTopLevel: (LispCons parse: aStream ifFail: aBlock)
1735	ifFail: aBlock! !
1736
1737!LispInterpreter methodsFor: 'accessing'!
1738
1739textCollector
1740    ^textCollector!
1741
1742textCollector: anObject
1743    textCollector := anObject! !
1744
1745!LispInterpreter methodsFor: 'error handling'!
1746
1747fatal: message
1748    bindStack reverseDo: [:assoc | assoc key notNil ifTrue: [assoc value notNil
1749		ifTrue: [self
1750			putprop: assoc key
1751			key: #apval
1752			value: assoc value]
1753		ifFalse: [self remprop: assoc key key: #apval]]].
1754    ^failBlock value: '*** Error: ' , message! !
1755
1756!LispInterpreter methodsFor: 'evaluating'!
1757
1758evaluate: sExpression
1759    | apval |
1760    (sExpression isKindOf: LispList)
1761	ifTrue: [^self listEvaluate: sExpression].
1762    (sExpression isKindOf: Symbol)
1763	ifTrue:
1764	    [sExpression = #t ifTrue: [^#t].
1765	    lispTable intern: sExpression.
1766	    apval := lispTable getprop: sExpression key: #apval.
1767	    apval isNil ifTrue: [^self fatal: (self printString: sExpression)
1768			, ' is unbound atom'].
1769	    ^apval].
1770    ^sExpression!
1771
1772evaluateTopLevel: sExpression
1773    ^self evaluateTopLevel: sExpression ifFail:
1774	[:errorMessage |
1775	Transcript show: errorMessage; nl.
1776	LispNil null]!
1777
1778evaluateTopLevel: sExpression ifFail: aBlock
1779    failBlock := aBlock.
1780    ^self evaluate: sExpression!
1781
1782listEvaluate: sExpression
1783    | funcName arguList funcBody |
1784    sExpression null ifTrue: [^sExpression].
1785    funcName := sExpression head.
1786    arguList := sExpression tail.
1787    (funcName isKindOf: LispCons)
1788	ifTrue:
1789	    [funcBody := funcName.
1790	    funcBody head = #lambda
1791		ifTrue:
1792		    [funcBody := LispCons head: #lambda tail: funcBody.
1793		    ^self exprEval: funcBody arguList: arguList].
1794	    funcBody head = #nlambda
1795		ifTrue:
1796		    [funcBody := LispCons head: #nlambda tail: funcBody.
1797		    ^self fexprEval: funcBody arguList: arguList].
1798	    ^self fatal: 'unexpected function ' , (self printString: funcBody)].
1799    (funcName isKindOf: Symbol)
1800	ifFalse: [^self fatal: 'null function ' , (self printString: funcName)].
1801    funcBody := self getprop: funcName key: #fexpr.
1802    funcBody = LispNil null ifFalse: [^self fexprEval: funcBody arguList: arguList].
1803    funcBody := self getprop: funcName key: #expr.
1804    funcBody = LispNil null ifFalse: [^self exprEval: funcBody arguList: arguList].
1805    funcBody := self getprop: funcName key: #fsubr.
1806    funcBody = LispNil null ifFalse: [^self fsubrEval: funcBody arguList: arguList].
1807    funcBody := self getprop: funcName key: #subr.
1808    funcBody = LispNil null ifFalse: [^self subrEval: funcBody arguList: arguList].
1809    ^self fatal: 'undefined function ' , (self printString: funcName)! !
1810
1811!LispInterpreter methodsFor: 'fsubr functions'!
1812
1813fsubrAdd: arguList
1814    | v a |
1815    v := LispNil null.
1816    arguList
1817	do:
1818	    [:each |
1819	    a := self evaluate: each.
1820	    (a isKindOf: Number)
1821		ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for +'].
1822	    v = LispNil null
1823		ifTrue: [v := a]
1824		ifFalse: [v := v + a]].
1825    ^v!
1826
1827fsubrCond: arguList
1828    | result |
1829    arguList do: [:each | (self evaluate: each head)
1830	    ~= LispNil null
1831	    ifTrue:
1832		[result := LispNil null.
1833		(each tail isKindOf: LispCons)
1834		    ifTrue: [each tail do: [:expr | result := self evaluate: expr]].
1835		^result]].
1836    ^LispNil null!
1837
1838fsubrDefun: arguList
1839    | funcName funcType |
1840    funcName := arguList head.
1841    (funcName isKindOf: Symbol)
1842	ifFalse: [^self fatal: 'unexpected function name ' , (self printString: funcName) , ' for defun'].
1843    funcType := arguList tail head.
1844    funcType = #lambda
1845	ifTrue:
1846	    [self
1847		putprop: funcName
1848		key: #expr
1849		value: arguList.
1850	    ^funcName].
1851    funcType = #nlambda
1852	ifTrue:
1853	    [self
1854		putprop: funcName
1855		key: #fexpr
1856		value: arguList.
1857	    ^funcName].
1858    self
1859	putprop: funcName
1860	key: #expr
1861	value: (LispCons head: funcName tail: (LispCons head: #lambda tail: arguList tail)).
1862    ^funcName!
1863
1864fsubrDiv: arguList
1865    | v a |
1866    v := LispNil null.
1867    arguList
1868	do:
1869	    [:each |
1870	    a := self evaluate: each.
1871	    (a isKindOf: Number)
1872		ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for /'].
1873	    v = LispNil null
1874		ifTrue: [v := a]
1875		ifFalse: [v := v / a]].
1876    ^v!
1877
1878fsubrDo: arguList
1879    | locals executions result |
1880    locals := arguList head.
1881    executions := arguList tail.
1882    self bindMark.
1883    locals do: [:lvar | self bind: lvar value: LispNil null].
1884    result := LispNil null.
1885    executions do: [:each | result := self evaluate: each].
1886    self unbind.
1887    ^result!
1888
1889fsubrIdiv: arguList
1890    | v a |
1891    v := LispNil null.
1892    arguList
1893	do:
1894	    [:each |
1895	    a := self evaluate: each.
1896	    (a isKindOf: Number)
1897		ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for //'].
1898	    v = LispNil null
1899		ifTrue: [v := a]
1900		ifFalse: [v := v // a]].
1901    ^v!
1902
1903fsubrIf: arguList
1904    | predicate then list truePart falsePart bool result |
1905    predicate := arguList head.
1906    then := arguList tail head.
1907    list := arguList tail tail.
1908    truePart := LispNil null.
1909    falsePart := LispNil null.
1910    bool := true.
1911    list do: [:each | each = #else
1912	    ifTrue: [bool := false]
1913	    ifFalse: [bool
1914		    ifTrue: [truePart := LispCons head: each tail: truePart]
1915		    ifFalse: [falsePart := LispCons head: each tail: falsePart]]].
1916    then = #then ifFalse: [^self fatal: 'unexpected format for if'].
1917    truePart := truePart reverse.
1918    falsePart := falsePart reverse.
1919    result := LispNil null.
1920    (self evaluate: predicate)
1921	= LispNil null
1922	ifTrue: [falsePart do: [:each | result := self evaluate: each]]
1923	ifFalse: [truePart do: [:each | result := self evaluate: each]].
1924    ^result!
1925
1926fsubrMlt: arguList
1927    | v a |
1928    v := LispNil null.
1929    arguList
1930	do:
1931	    [:each |
1932	    a := self evaluate: each.
1933	    (a isKindOf: Number)
1934		ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for *'].
1935	    v = LispNil null
1936		ifTrue: [v := a]
1937		ifFalse: [v := v * a]].
1938    ^v!
1939
1940fsubrMod: arguList
1941    | v a |
1942    v := LispNil null.
1943    arguList
1944	do:
1945	    [:each |
1946	    a := self evaluate: each.
1947	    (a isKindOf: Number)
1948		ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for \\'].
1949	    v = LispNil null
1950		ifTrue: [v := a]
1951		ifFalse: [v := v \\ a]].
1952    ^v!
1953
1954fsubrProgn: arguList
1955    | result |
1956    result := LispNil null.
1957    arguList do: [:each | result := self evaluate: each].
1958    ^result!
1959
1960fsubrQuote: arguList
1961    ^arguList head!
1962
1963fsubrRepeat: arguList
1964    | reverse predicate until executions result |
1965    reverse := arguList reverse.
1966    predicate := reverse head.
1967    until := reverse tail head.
1968    executions := reverse tail tail reverse.
1969    until = #until ifFalse: [^self fatal: 'unexpected format for repeat'].
1970    result := LispNil null.
1971    executions do: [:each | result := self evaluate: each].
1972    [(self evaluate: predicate)
1973	= LispNil null]
1974	whileFalse: [executions do: [:each | result := self evaluate: each]].
1975    ^result!
1976
1977fsubrSend: arguList
1978    | list receiver selector arguments result |
1979    list := arguList.
1980    receiver := self evaluate: list head.
1981    list := list tail.
1982    selector := self evaluate: list head.
1983    (selector isKindOf: Symbol)
1984	ifFalse: [^self fatal: 'unexpected selector ' , (self printString: selector) , ' for send'].
1985    list := list tail.
1986    arguments := OrderedCollection new.
1987    [list isKindOf: LispCons]
1988	whileTrue:
1989	    [arguments add: (self evaluate: list head).
1990	    list := list tail].
1991    result := receiver perform: selector withArguments: arguments asArray.
1992    ^result!
1993
1994fsubrSetq: arguList
1995    | list a1 a2 |
1996    list := arguList.
1997    a2 := LispNil null.
1998    [list isKindOf: LispCons]
1999	whileTrue:
2000	    [a1 := list head.
2001	    (a1 isKindOf: Symbol)
2002		ifFalse: [^self fatal: 'unexpected variable ' , (self printString: a1) , ' for setq'].
2003	    list := list tail.
2004	    a2 := self evaluate: list head.
2005	    self
2006		putprop: a1
2007		key: #apval
2008		value: a2.
2009	    list := list tail].
2010    ^a2!
2011
2012fsubrSub: arguList
2013    | v a |
2014    v := LispNil null.
2015    arguList
2016	do:
2017	    [:each |
2018	    a := self evaluate: each.
2019	    (a isKindOf: Number)
2020		ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a) , ' for -'].
2021	    v = LispNil null
2022		ifTrue: [v := a]
2023		ifFalse: [v := v - a]].
2024    ^v!
2025
2026fsubrWhile: arguList
2027    | predicate do executions result |
2028    predicate := arguList head.
2029    do := arguList tail head.
2030    executions := arguList tail tail.
2031    do = #do ifFalse: [^self fatal: 'unexpected format for while'].
2032    result := LispNil null.
2033    [(self evaluate: predicate)
2034	= LispNil null]
2035	whileFalse: [executions do: [:each | result := self evaluate: each]].
2036    ^result! !
2037
2038!LispInterpreter methodsFor: 'func eval'!
2039
2040exprEval: funcBody arguList: arguList
2041    | expression funcName lvarList lvar result |
2042    expression := funcBody.
2043    funcName := expression head.
2044    expression := expression tail.
2045    expression := expression tail.
2046    lvarList := expression head.
2047    expression := expression tail.
2048    arguList length ~= lvarList length ifTrue: [^self fatal: 'too few or many arguments ' , (self printString: arguList) , ' vs ' , (self printString: lvarList) , ' for ' , funcName].
2049    self bindMark.
2050    arguList
2051	do:
2052	    [:each |
2053	    lvar := lvarList head.
2054	    self bind: lvar value: (self evaluate: each).
2055	    lvarList := lvarList tail].
2056    expression do: [:each | result := self evaluate: each].
2057    self unbind.
2058    ^result!
2059
2060fexprEval: funcBody arguList: arguList
2061    | expression funcName lvarList lvar result |
2062    expression := funcBody.
2063    funcName := expression head.
2064    expression := expression tail.
2065    expression := expression tail.
2066    lvarList := expression head.
2067    expression := expression tail.
2068    lvarList length ~= 1 ifTrue: [^self fatal: 'too few or many arguments ' , (self printString: lvarList) , ' for ' , (self printString: funcName)].
2069    self bindMark.
2070    lvar := lvarList head.
2071    self bind: lvar value: arguList.
2072    expression do: [:each | result := self evaluate: each].
2073    self unbind.
2074    ^result!
2075
2076fsubrEval: funcBody arguList: arguList
2077    | messageSelector |
2078    messageSelector := funcBody tail head.
2079    ^self perform: messageSelector with: arguList!
2080
2081subrEval: funcBody arguList: arguList
2082    | funcName messageSelector arguCount arguBuffer list |
2083    funcName := funcBody head.
2084    messageSelector := funcBody tail head.
2085    arguCount := funcBody tail tail head.
2086    arguBuffer := OrderedCollection new.
2087    list := arguList.
2088    arguCount
2089	timesRepeat:
2090	    [list null ifTrue: [^self fatal: 'too few arguments for ' , (self printString: funcName)].
2091	    arguBuffer add: (self evaluate: list head).
2092	    list := list tail].
2093    list null not ifTrue: [^self fatal: 'too many arguments for ' , (self printString: funcName)].
2094    arguBuffer isEmpty
2095	ifTrue: [^self perform: messageSelector]
2096	ifFalse: [^self perform: messageSelector with: arguBuffer asArray]! !
2097
2098!LispInterpreter methodsFor: 'initialize-release'!
2099
2100initialize
2101    lispTable := LispTable new.
2102    bindStack := OrderedCollection new.
2103    failBlock := [:errorMessage | self error: errorMessage].
2104    textCollector := Transcript.
2105    self initializeSubrFunctions.
2106    self initializeFsubrFunctions.
2107    self initializeExprFunctions.
2108    self initializeFexprFunctions!
2109
2110initializeExprFunctions
2111    self evaluateTopLevel: (LispParser parse: '
2112
2113    % Expr Functions
2114    (progn
2115
2116	% ++
2117	(defun ++ lambda (x)
2118	    (+ x 1))
2119
2120	% --
2121	(defun -- lambda (x)
2122	    (- x 1))
2123
2124	% assoc
2125	(defun assoc lambda (x a)
2126	    (cond
2127		((null a) nil)
2128		((equal x (car (car a))) (car a))
2129		(t (assoc x (cdr a)))))
2130
2131	% copy
2132	(defun copy lambda (x)
2133	    (cond
2134		((null x) nil)
2135		(t (cons (car x) (copy (cdr x))))))
2136
2137	% mapc
2138	(defun mapc lambda (f x)
2139	    (cond
2140		((null x) nil)
2141		(t (progn
2142		    (eval (cons f (cons `(car x) nil)))
2143		    (mapc f (cdr x))))))
2144
2145	% mapcar
2146	(defun mapcar lambda (f x)
2147	    (cond
2148		((null x) nil)
2149		(t (cons
2150		    (eval (cons f (cons `(car x) nil)))
2151		    (mapcar f (cdr x))))))
2152
2153	) % end
2154
2155    ')!
2156
2157initializeFexprFunctions
2158    self evaluateTopLevel: (LispParser parse: '
2159
2160    % Expr Functions
2161    (progn
2162
2163	% and
2164	(defun and nlambda (x)
2165	    (do    (list)
2166		(setq list x)
2167		(while
2168		    (if (null list) then nil else (eval (car list)))
2169		    do
2170		    (setq list (cdr list)))
2171		(if (null list) then t else nil)))
2172
2173	% list
2174	(defun list nlambda (x)
2175	    (mapcar `eval x))
2176
2177	% or
2178	(defun or nlambda (x)
2179	    (do    (list)
2180		(setq list x)
2181		(while
2182		    (if (null list) then nil else (not (eval (car list))))
2183		    do
2184		    (setq list (cdr list)))
2185		(if (null list) then nil else t)))
2186
2187	) % end
2188
2189    ')!
2190
2191initializeFsubrFunctions
2192    self setFsubrFunc: #(#* #fsubrMlt:).
2193    self setFsubrFunc: #(#+ #fsubrAdd:).
2194    self setFsubrFunc: #(#- #fsubrSub:).
2195    self setFsubrFunc: #(#/ #fsubrDiv:).
2196    self setFsubrFunc: #(#// #fsubrIdiv:).
2197    self setFsubrFunc: #(#cond #fsubrCond:).
2198    self setFsubrFunc: #(#defun #fsubrDefun:).
2199    self setFsubrFunc: #(#do #fsubrDo:).
2200    self setFsubrFunc: #(#if #fsubrIf:).
2201    self setFsubrFunc: #(#progn #fsubrProgn:).
2202    self setFsubrFunc: #(#quote #fsubrQuote:).
2203    self setFsubrFunc: #(#repeat #fsubrRepeat:).
2204    self setFsubrFunc: #(#send #fsubrSend:).
2205    self setFsubrFunc: #(#setq #fsubrSetq:).
2206    self setFsubrFunc: #(#while #fsubrWhile:).
2207    self setFsubrFunc: #(#\\ #fsubrMod:).!
2208
2209initializeSubrFunctions
2210    self setSubrFunc: #(#< #subrLt: 2).
2211    self setSubrFunc: #(#<= #subrLe: 2).
2212    self setSubrFunc: #(#= #subrEqual: 2).
2213    self setSubrFunc: #(#== #subrEq: 2).
2214    self setSubrFunc: #(#> #subrGt: 2).
2215    self setSubrFunc: #(#>= #subrGe: 2).
2216    self setSubrFunc: #(#append #subrAppend: 2).
2217    self setSubrFunc: #(#atom #subrAtom: 1).
2218    self setSubrFunc: #(#car #subrCar: 1).
2219    self setSubrFunc: #(#cdr #subrCdr: 1).
2220    self setSubrFunc: #(#cons #subrCons: 2).
2221    self setSubrFunc: #(#consp #subrConsp: 1).
2222    self setSubrFunc: #(#dtpr #subrConsp: 1).
2223    self setSubrFunc: #(#doublep #subrDoublep: 1).
2224    self setSubrFunc: #(#eq #subrEq: 2).
2225    self setSubrFunc: #(#equal #subrEqual: 2).
2226    self setSubrFunc: #(#eval #subrEval: 1).
2227    self setSubrFunc: #(#exprs #subrExprs 0).
2228    self setSubrFunc: #(#fexprs #subrFexprs 0).
2229    self setSubrFunc: #(#floatp #subrFloatp: 1).
2230    self setSubrFunc: #(#fsubrs #subrFsubrs 0).
2231    self setSubrFunc: #(#gc #subrGc 0).
2232    self setSubrFunc: #(#gensym #subrGensym 0).
2233    self setSubrFunc: #(#getprop #subrGetprop: 2).
2234    self setSubrFunc: #(#integerp #subrIntegerp: 1).
2235    self setSubrFunc: #(#last #subrLast: 1).
2236    self setSubrFunc: #(#length #subrLength: 1).
2237    self setSubrFunc: #(#listp #subrListp: 1).
2238    self setSubrFunc: #(#member #subrMember: 2).
2239    self setSubrFunc: #(#memq #subrMemq: 2).
2240    self setSubrFunc: #(#nconc #subrNconc: 2).
2241    self setSubrFunc: #(#neq #subrNeq: 2).
2242    self setSubrFunc: #(#nequal #subrNequal: 2).
2243    self setSubrFunc: #(#not #subrNull: 1).
2244    self setSubrFunc: #(#nth #subrNth: 2).
2245    self setSubrFunc: #(#null #subrNull: 1).
2246    self setSubrFunc: #(#numberp #subrNumberp: 1).
2247    self setSubrFunc: #(#oblist #subrOblist 0).
2248    self setSubrFunc: #(#pp #subrPp: 1).
2249    self setSubrFunc: #(#princ #subrPrinc: 1).
2250    self setSubrFunc: #(#print #subrPrint: 1).
2251    self setSubrFunc: #(#putprop #subrPutprop: 3).
2252    self setSubrFunc: #(#remprop #subrRemprop: 2).
2253    self setSubrFunc: #(#reverse #subrReverse: 1).
2254    self setSubrFunc: #(#rplaca #subrRplaca: 2).
2255    self setSubrFunc: #(#rplacd #subrRplacd: 2).
2256    self setSubrFunc: #(#stringp #subrStringp: 1).
2257    self setSubrFunc: #(#subrs #subrSubrs 0).
2258    self setSubrFunc: #(#symbolp #subrSymbolp: 1).
2259    self setSubrFunc: #(#terpri #subrTerpri 0).
2260    self setSubrFunc: #(#~= #subrNequal: 2).
2261    self setSubrFunc: #(#~~ #subrNeq: 2)! !
2262
2263!LispInterpreter methodsFor: 'printing'!
2264
2265printString: anObject
2266    ^self class printString: anObject! !
2267
2268!LispInterpreter methodsFor: 'private'!
2269
2270setFsubrFunc: bodyArray
2271    self
2272	putprop: (bodyArray at: 1) asSymbol
2273	key: #fsubr
2274	value: (LispCons list: bodyArray)!
2275
2276setSubrFunc: bodyArray
2277    self
2278	putprop: (bodyArray at: 1) asSymbol
2279	key: #subr
2280	value: (LispCons list: bodyArray)! !
2281
2282!LispInterpreter methodsFor: 'property access'!
2283
2284getprop: identifier key: key
2285    | value |
2286    lispTable intern: identifier.
2287    value := lispTable getprop: identifier key: key.
2288    value isNil ifTrue: [^LispNil null].
2289    ^value!
2290
2291putprop: identifier key: key value: value
2292    lispTable intern: identifier.
2293    ^lispTable
2294	putprop: identifier
2295	key: key
2296	value: value!
2297
2298remprop: identifier key: key
2299    | value |
2300    lispTable intern: identifier.
2301    value := lispTable remprop: identifier key: key.
2302    value isNil ifTrue: [^LispNil null].
2303    ^value! !
2304
2305!LispInterpreter methodsFor: 'shallow binding'!
2306
2307bind: symbol value: value
2308    | saveValue assoc |
2309    lispTable intern: symbol.
2310    saveValue := lispTable getprop: symbol key: #apval.
2311    assoc := Association key: symbol value: saveValue.
2312    bindStack addLast: assoc.
2313    self
2314	putprop: symbol
2315	key: #apval
2316	value: value!
2317
2318bindMark
2319    | assoc |
2320    assoc := Association key: nil value: nil.
2321    bindStack addLast: assoc!
2322
2323unbind
2324    | assoc |
2325
2326    [assoc := bindStack removeLast.
2327    assoc key notNil]
2328	whileTrue: [assoc value notNil
2329		ifTrue: [self
2330			putprop: assoc key
2331			key: #apval
2332			value: assoc value]
2333		ifFalse: [self remprop: assoc key key: #apval]]! !
2334
2335!LispInterpreter methodsFor: 'subr functions'!
2336
2337subrAppend: arguArray
2338    | a1 a2 |
2339    a1 := arguArray at: 1.
2340    a2 := arguArray at: 2.
2341    (a1 isKindOf: LispCons)
2342	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for append'].
2343    (a2 isKindOf: LispCons)
2344	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for append'].
2345    ^a1 append: a2!
2346
2347subrAtom: arguArray
2348    | a1 |
2349    a1 := arguArray at: 1.
2350    (a1 isKindOf: LispCons) ifFalse: [^#t].
2351    ^LispNil null!
2352
2353subrCar: arguArray
2354    | list |
2355    list := arguArray at: 1.
2356    (list isKindOf: LispCons)
2357	ifTrue: [^list head].
2358    (list isKindOf: LispNil)
2359	ifTrue: [^LispNil null].
2360    ^self fatal: 'unexpected argument ' , (self printString: list) , ' for car'!
2361
2362subrCdr: arguArray
2363    | list |
2364    list := arguArray at: 1.
2365    (list isKindOf: LispCons)
2366	ifTrue: [^list tail].
2367    (list isKindOf: LispNil)
2368	ifTrue: [^LispNil null].
2369    ^self fatal: 'unexpected argument ' , (self printString: list) , ' for cdr'!
2370
2371subrCons: arguArray
2372    ^LispCons head: (arguArray at: 1)
2373	tail: (arguArray at: 2)!
2374
2375subrConsp: arguArray
2376    | a1 |
2377    a1 := arguArray at: 1.
2378    (a1 isKindOf: LispCons)
2379	ifTrue: [^#t].
2380    ^LispNil null!
2381
2382subrDoublep: arguArray
2383    | a1 |
2384    ^self subrFloatp: arguArray
2385    "a1 := arguArray at: 1.
2386    (a1 isKindOf: Double)
2387	ifTrue: [^#t].
2388    ^LispNil null"!
2389
2390subrEq: arguArray
2391    | bool |
2392    (arguArray at: 1)
2393	== (arguArray at: 2)
2394	ifTrue: [bool := #t]
2395	ifFalse: [bool := LispNil null].
2396    ^bool!
2397
2398subrEqual: arguArray
2399    | bool |
2400    (arguArray at: 1)
2401	= (arguArray at: 2)
2402	ifTrue: [bool := #t]
2403	ifFalse: [bool := LispNil null].
2404    ^bool!
2405
2406subrEval: arguArray
2407    ^self evaluate: (arguArray at: 1)!
2408
2409subrExprs
2410    | list |
2411    list := LispNil null.
2412    self subrOblist reverse do: [:id | (self getprop: id key: #expr)
2413	    = LispNil null ifFalse: [list := LispCons head: id tail: list]].
2414    ^list!
2415
2416subrFexprs
2417    | list |
2418    list := LispNil null.
2419    self subrOblist reverse do: [:id | (self getprop: id key: #fexpr)
2420	    = LispNil null ifFalse: [list := LispCons head: id tail: list]].
2421    ^list!
2422
2423subrFloatp: arguArray
2424    | a1 |
2425    a1 := arguArray at: 1.
2426    (a1 isKindOf: Float)
2427	ifTrue: [^#t].
2428    ^LispNil null!
2429
2430subrFsubrs
2431    | list |
2432    list := LispNil null.
2433    self subrOblist reverse do: [:id | (self getprop: id key: #fsubr)
2434	    = LispNil null ifFalse: [list := LispCons head: id tail: list]].
2435    ^list!
2436
2437subrGc
2438    "ObjectMemory globalCompactingGC."
2439    Smalltalk compact.
2440    Transcript nl; show: 'garbage collecting'.
2441    ^#t!
2442
2443subrGe: arguArray
2444    | a1 a2 |
2445    a1 := arguArray at: 1.
2446    a2 := arguArray at: 2.
2447    (a1 isKindOf: LispList)
2448	ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for >='].
2449    (a2 isKindOf: LispList)
2450	ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for >='].
2451    a1 >= a2 ifTrue: [^#t].
2452    ^LispNil null!
2453
2454subrGensym
2455    | clock |
2456    (Delay forMilliseconds: 1) wait.
2457    clock := Time millisecondClockValue.
2458    ^('id' , clock printString) asSymbol!
2459
2460subrGetprop: arguArray
2461    | a1 a2 |
2462    a1 := arguArray at: 1.
2463    a2 := arguArray at: 2.
2464    (a1 isKindOf: Symbol)
2465	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for getprop'].
2466    (a2 isKindOf: Symbol)
2467	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for getprop'].
2468    ^self getprop: a1 key: a2!
2469
2470subrGt: arguArray
2471    | a1 a2 |
2472    a1 := arguArray at: 1.
2473    a2 := arguArray at: 2.
2474    (a1 isKindOf: LispList)
2475	ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for >'].
2476    (a2 isKindOf: LispList)
2477	ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for >'].
2478    a1 > a2 ifTrue: [^#t].
2479    ^LispNil null!
2480
2481subrIntegerp: arguArray
2482    | a1 |
2483    a1 := arguArray at: 1.
2484    (a1 isKindOf: Integer)
2485	ifTrue: [^#t].
2486    ^LispNil null!
2487
2488subrLast: arguArray
2489    | list |
2490    list := arguArray at: 1.
2491    (list isKindOf: LispCons)
2492	ifTrue: [^list last].
2493    ^self fatal: 'unexpected argument ' , (self printString: list) , ' for last'!
2494
2495subrLe: arguArray
2496    | a1 a2 |
2497    a1 := arguArray at: 1.
2498    a2 := arguArray at: 2.
2499    (a1 isKindOf: LispList)
2500	ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for <='].
2501    (a2 isKindOf: LispList)
2502	ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for <='].
2503    a1 <= a2 ifTrue: [^#t].
2504    ^LispNil null!
2505
2506subrLength: arguArray
2507    | list |
2508    list := arguArray at: 1.
2509    (list isKindOf: LispCons)
2510	ifTrue: [^list length].
2511    ^self fatal: 'unexpected argument ' , (self printString: list) , ' for length'!
2512
2513subrListp: arguArray
2514    | a1 |
2515    a1 := arguArray at: 1.
2516    (a1 isKindOf: LispList)
2517	ifTrue: [^#t].
2518    ^LispNil null!
2519
2520subrLt: arguArray
2521    | a1 a2 |
2522    a1 := arguArray at: 1.
2523    a2 := arguArray at: 2.
2524    (a1 isKindOf: LispList)
2525	ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for <'].
2526    (a2 isKindOf: LispList)
2527	ifTrue: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for <'].
2528    a1 < a2 ifTrue: [^#t].
2529    ^LispNil null!
2530
2531subrMember: arguArray
2532    | a1 a2 |
2533    a1 := arguArray at: 1.
2534    a2 := arguArray at: 2.
2535    (a2 isKindOf: LispCons)
2536	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for member'].
2537    ^a2 member: a1!
2538
2539subrMemq: arguArray
2540    | a1 a2 |
2541    a1 := arguArray at: 1.
2542    a2 := arguArray at: 2.
2543    (a2 isKindOf: LispCons)
2544	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for memq'].
2545    ^a2 memq: a1!
2546
2547subrNconc: arguArray
2548    | a1 a2 |
2549    a1 := arguArray at: 1.
2550    a2 := arguArray at: 2.
2551    (a1 isKindOf: LispCons)
2552	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for nconc'].
2553    a1 nconc: a2.
2554    ^a1!
2555
2556subrNeq: arguArray
2557    | bool |
2558    ((arguArray at: 1)
2559	== (arguArray at: 2)) not
2560	ifTrue: [bool := #t]
2561	ifFalse: [bool := LispNil null].
2562    ^bool!
2563
2564subrNequal: arguArray
2565    | bool |
2566    ((arguArray at: 1)
2567	= (arguArray at: 2)) not
2568	ifTrue: [bool := #t]
2569	ifFalse: [bool := LispNil null].
2570    ^bool!
2571
2572subrNth: arguArray
2573    | a1 a2 |
2574    a1 := arguArray at: 1.
2575    a2 := arguArray at: 2.
2576    (a1 isKindOf: Number)
2577	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for nth'].
2578    (a2 isKindOf: LispCons)
2579	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for nth'].
2580    ^a2 nth: a1!
2581
2582subrNull: arguArray
2583    ((arguArray at: 1)
2584	isMemberOf: LispNil)
2585	ifTrue: [^#t].
2586    ^LispNil null!
2587
2588subrNumberp: arguArray
2589    | a1 |
2590    a1 := arguArray at: 1.
2591    (a1 isKindOf: Number)
2592	ifTrue: [^#t].
2593    ^LispNil null!
2594
2595subrOblist
2596    | list |
2597    list := LispNil null.
2598    lispTable identifiers reverseDo: [:each | list := LispCons head: each tail: list].
2599    ^list!
2600
2601subrPp: arguArray
2602    | a pretty |
2603    a := arguArray at: 1.
2604    pretty := a ppString.
2605    textCollector show: pretty.
2606    ^a!
2607
2608subrPrinc: arguArray
2609    | a |
2610    a := arguArray at: 1.
2611    (a isKindOf: String)
2612	ifTrue: [textCollector show: a]
2613	ifFalse: [textCollector show: (self printString: a)].
2614    ^a!
2615
2616subrPrint: arguArray
2617    | a |
2618    a := self subrPrinc: arguArray.
2619    textCollector nl.
2620    ^a!
2621
2622subrPutprop: arguArray
2623    | a1 a2 a3 |
2624    a1 := arguArray at: 1.
2625    a2 := arguArray at: 2.
2626    a3 := arguArray at: 3.
2627    (a1 isKindOf: Symbol)
2628	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for putprop'].
2629    (a2 isKindOf: Symbol)
2630	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for putprop'].
2631    ^self
2632	putprop: a1
2633	key: a2
2634	value: a3!
2635
2636subrRemprop: arguArray
2637    | a1 a2 |
2638    a1 := arguArray at: 1.
2639    a2 := arguArray at: 2.
2640    (a1 isKindOf: Symbol)
2641	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for remprop'].
2642    (a2 isKindOf: Symbol)
2643	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for remprop'].
2644    ^self remprop: a1 key: a2!
2645
2646subrReverse: arguArray
2647    | a1 |
2648    a1 := arguArray at: 1.
2649    (a1 isKindOf: LispCons)
2650	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a1) , ' for reverse'].
2651    ^a1 reverse!
2652
2653subrRplaca: arguArray
2654    | a1 a2 |
2655    a1 := arguArray at: 1.
2656    a2 := arguArray at: 2.
2657    (a1 isKindOf: LispCons)
2658	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for rplaca'].
2659    a1 rplaca: a2.
2660    ^a1!
2661
2662subrRplacd: arguArray
2663    | a1 a2 |
2664    a1 := arguArray at: 1.
2665    a2 := arguArray at: 2.
2666    (a1 isKindOf: LispCons)
2667	ifFalse: [^self fatal: 'unexpected argument ' , (self printString: a2) , ' for rplacd'].
2668    a1 rplacd: a2.
2669    ^a1!
2670
2671subrStringp: arguArray
2672    | a1 |
2673    a1 := arguArray at: 1.
2674    ((a1 isKindOf: String)
2675	and: [(a1 isKindOf: Symbol) not])
2676	ifTrue: [^#t].
2677    ^LispNil null!
2678
2679subrSubrs
2680    | list |
2681    list := LispNil null.
2682    self subrOblist reverse do: [:id | (self getprop: id key: #subr)
2683	    = LispNil null ifFalse: [list := LispCons head: id tail: list]].
2684    ^list!
2685
2686subrSymbolp: arguArray
2687    | a1 |
2688    a1 := arguArray at: 1.
2689    (a1 isKindOf: Symbol) ifTrue: [^#t].
2690    ^LispNil null!
2691
2692subrTerpri
2693    textCollector nl.
2694    ^#t! !
2695
2696
2697
2698
2699