-
Notifications
You must be signed in to change notification settings - Fork 6
/
LISP.TXT
2435 lines (2435 loc) · 43.4 KB
/
LISP.TXT
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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
*
**************** LISP 1.5 *************************
*
* COPYRIGHT 1978 BY
*
* FRITS VAN DER WATEREN
* VAN 'T HOFFSTRAAT 140
* 2014 RK HAARLEM
* THE NETHERLANDS
*
*
*
*
* LIST STARTS AT $100.
* AND AUTOMATICALY ALLOCATES ALL CONTIGUOUS MEMORY
* AND RESERVES 7/8 FOR CELL STORAGE (4 BYTES PER CELL
* AND 1/8 FOR STACK (2 BYTES PER WORD).
*
* RESTART IS AT $103
* THE CURRENT OBLIST IS MAINTAINED BUT THE
* A-LIST BINDINGS ARE LOST.
* FURTHERMORE A GARBAGE COLLECTION IS FORCED.
*
* THE DEVICE TABLE IS LOCATED AT $106
* AND CAN BE EXTENDED BY TWO MORE DEVICES.
* IMPLEMENTED HANDLERS ARE:
* #1 TTY WITH AN ACIA AT $8004
* #2 READER WITH A PIA AT $8010 (A)
* #3 PUNCH WITH A PIA AT $8010 (B)
PAG
ORG 0
SPC1
NIL RMB 4 ATOM NIL
FWAM RMB 2 FIRST WORD OF CELL STORAGE
LWAM RMB 2 LAST WORD OF CELL STORAGE
STACK RMB 2 BOTTOM OF STACK
LIMIT RMB 2 STACK-LIMIT REGISTER
OBLSTB RMB 2 POINTER TO OBJECT-LIST.
N RMB 2
FREE RMB 2 POINTER TO FREE LIST
CURCEL RMB 2 POINTER TO CURRENT CELL
ARG1 RMB 2 HOLDS ARGUMENT 1 DURING EVALUATION
ARG2 RMB 2
ARG3 RMB 2
PROGB RMB 2 BEGIN OF CURRENT PROG-LIST
RUNP RMB 2 RUNNING POINTER ON PROG-LIST
OBLSTP RMB 2
OP RMB 2
AP RMB 2
NUM1 RMB 2
NUM2 RMB 2
SAVEX RMB 2
TEMPX RMB 2
MP RMB 2
PNAME RMB 2
STEPC RMB 1
SIGN RMB 1
CP RMB 2 POINTER TO CURRENT INPUT CHAR.
DELFLG RMB 1
DEVICE RMB 2 POINTS TO I/O HANDLER LINK ADDRESS
CCOUNT RMB 1 CHARACTER COUNT FOR OUTPUT.
SPC1
M EQU 1 MARKER
F EQU $80 FILL CHARACTER
SPC1
FIRSTC EQU * REMAINDER IS INPUT-BUFFER
SPC1
ORG $100
LASTC EQU *-1
PAG
BEGIN JMP START COLD START.
JMP RSTART WARM START.
*
* DEVICE TABLE
*
* EACH ENTRY CONSISTS OF FOUR POINTERS
* TO I/O HANDLERS.
* POINTER 1 IS INPUT HANDLER
* POINTER 2 IS OUTPUT HANDLER
* POINTER 3 IS OPEN OR INITIALIZE
* POINTER 4 IS CLOSE
*
* DEVICE #1 IS THE SYSTEM DEVICE
*
*
DEVTBL FDB TTYIN,TTYOUT,TTYOPN,ABORT
FDB RDRIN,DUMMY,RDOPN,TR
FDB DUMMY,PUNOUT,PUNOPN,PUNCLS
FDB 0,0,0,0 #4 FOR EXTENSION
FDB 0,0,0,0 #5 FOR EXTENSION
FDB 0 ZERO ENDS THE TABLE
PAG
START LDX #NAMNIL+M SET ATOM NIL AT $0000
STX NIL
LDX #PRPNIL
STX NIL+2
LDX #OBLIST
STX OBLSTB BEGIN OF OBLIST
LDX #LISPSP
STX FWAM FIRST FREE CELL.
LDAA #%10001011
SEEK STAA 0,X ALLOCATE ALL
CMPA 0,X CONTIGUOUS MEMORY
BNE END RIGHT AFTER LISP.
CLR 0,X
INX
BRA SEEK
END TXS
STS STACK
LDAA STACK RESERVE STACK SPACE
LDAB STACK+1
SUBB FWAM+1
SBCA FWAM
LSRA
RORB
LSRA
RORB
LSRA
RORB
SUBB STACK+1
SBCA STACK
COMA
STAA LWAM LWAM=-(STACK/8-STACK)
LDAB #$80
STAB LWAM+1 ON PAGE-BOUNDRY+128
INCA
STACK-LIMIT ON PAGE BOUNDRY.
STAA LIMIT 128 BYTES FOR STACK OVERFLOW
CLR LIMIT+1
RSTR LDX #OBL1
STX ARG2
LDX #OBLIST
LDX 2,X
LDX 2,X
JSR RPLACA RESTORE OBLIST
RSTART LDS STACK
LDX #N
CLRLOC CLR 0,X CLEAR (NIL) WORK SPACE.
INX
CPX OBLSTP
BNE CLRLOC
LDX N
STX ARG1
JSR OPEN OPEN DEV #1
LDX #HED PRINT LISP 1.5 AND
JSR PMESSG VERSION NUMBER.
PAG
*************************************
* #*
* THE LISP INTERPRETER *
* #*
*************************************
SPC2
LISP LDS STACK
LDX N
JSR TEREAD
JSR TERPRI
JSR READ READ ONE S-EXPRESSION FROM DEV #
STX ARG1
LDX N
STX AGR2
STX PROGB
LDX ARG1
JSR EVAL EVALUATE
STX ARG1
LDX N
STX ARG2
JSR PRINT AND PRINT RESULT ON DEV #1
BRA LISP
PAG
*
* GET A CELL FROM THE FREE LIST
* ON EXIT X POINTS TO THIS CELL
*
CELL LDX FREE
BEQ GCOL FREE LIST IS EMPTY
STX CURCEL GET CELL
LDX 2,X ADVANCE POINTER TO NEXT
STX FREE FREE CELL ON LIST
LDX CURCEL
CLR 2,X CLEAN UP THIS CELL!
CLR 3,X
RTS
*
* GARBAGE COLLECTOR.
*
GCOL LDX ARG1
BSR MARKL MARK 3 CURRENT ARGS.
LDX ARG2
BSR MARKL
LDX ARG3
BSR MARKL
LDX PROGB
BSR MARKL MARK PROG
LDX OBLSTB
BSR MARKL MARK OBLIST.
TSX
DEX
GCOL1 CPX STACK
BEQ GCOL3
JSR PUSHX MARK ALL ACTIVE LISTS
LDAA 1,X ON THE STACK
LDAB 2,X
SUBB OBLSTB+1
SBCA OBLSTB
BMI GCOL2 POINTS IN SYSTEM AREA.
LDX 1,X
BSR MARKL
GCOL2 JSR PULLX
INX
INX
BRA GCOL1
GCOL3 LDX N
STX FREE
LDX LWAM
PAG
SWEEP CPX OBLSTB NOW SWEEP ALL UNMARKED CELLS
BEQ SWPDON ONTO THE FREE LIST.
DEX
DEX
DEX
DEX
LDAA 3,X
ASR 3,X UNMARK CELL
ASL 3,X
RORA
BCS SWEEP
LDAA FREE LINK AN UNMARKED CELL
LDAB FREE+1 TO THE FREE-LIST
CLR 0,X
CLR 1,X
STAA 2,X
STAB 3,X
STX FREE
BRA SWEEP
SWPDON LDX FREE
BEQ FULL NO FREE-LIST!
JMP CELL
SPC1
FULL LDX #FL.MS
SYSERR JSR PMESSG
JMP RSTART
PAG
*
* MARK ONE LIST
*
MARKL BEQ MARKEX EMPTY LIST
CLRA
PSHA
SET BOTTOM OF WORKSTACK TO NIL.
PSHA
MARK1 CPX #1 NUMERIC CELL?
BEQ MRKNUM YES
STX FREE
LDAA FREE
LDAB FREE+1
SUBB OBLSTB+1
SBCA OBLSTB NO; LIST IN SYSTEM AREA?
BMI MARK2 YES; UP ONE LEVEL
RORB
NO, ATOM CELL?
BCS MRKATM YES
LDAA 3,X
RORA
CELL MARKED?
BCS MARK2 YES,UP ONE LEVEL
INC 3,X NO,MARK CELL
JSR PUSHX
LDX 0,X DOWN ONE LEVEL
BRA MARK1
SPC1
MRKNAM INC 3,X MARK PRINTNAME OF ATOM
LDX 2,X
MRKATM DEX
BNE MRKNAM
BRA MARK2
MRKNUM JSR PULLX MARK ONE NUMERIC CELL
LDX 2,X
INC 2,X
MARK2 JSR PULLX UP ONE LEVEL
BEQ MARKEX TOP LEVEL! SO EXIT.
LDX 2,X
DEX TAKE CARE OF MARK
BEQ MARK2
BRA MARK1
MARKEX RTS
PAG
*
* INPUT ONE CHAR FROM TTY
*
TTYIN LDAA ACIACS
ASRA
BCC TTYIN
LDAA ACIADA
ANDA #$7F
RTS
*
* OUTPUT ONE CHAR ON TTY
*
TTYOUT LDAB ACIACS
ASRB
ASRB
BCC TTYOUT
STAA ACIADA
RTS
*
* OPEN TTY (INITIALIZE)
*
TTYOPN LDAA #%1
STAA ACIACS
BRA TR
SPC1
*
* ABORT IF CTRL/C (ETX) IS PRESSED
*
ABORT LDAA ACIACS IF CTRL/C IS PRESSED
ASRA
THEN ABORT EVALUATION.
BCC TR
LDAA ACIADA
CMPA #3
BNE TR
JMP LISP
TR JMP TRUE
SPC1
ACIACS EQU $8004 SWTPC PORT #1
ACIADA EQU $8005
PAG
*
* INPUT ONE CHARACTER FROM HIGH SPEED READER.
*
RDRIN LDAA RDRC
BPL RDRIN
LDAA RDR
COMA
ANDA #$7F
BEQ RDRIN IGNORE NULLS
CMPA #$7F
BEQ RDRIN IGNORE RUBOUT
CMPA #$A
BEQ RDRIN IGNORE LF
DUMMY RTS
*
* OPEN READER (INITIALIZE)
*
RDROPN CLR RDRC
CLR RDR
LDAA #%101110
STAA RDRC
LDAA RDR SET FLAG
BRA TR
*
* OUTPUT ONE CHARACTER ON PUNCH.
*
PUNOUT LDAB PUNC
BPL PUNOUT
STAA PUN
RTS
*
* OPEN PUNCH (INITIALIZE) AND PUNCH LEADER.
*
PUNOPN CLR PUNC
CLR PUN
LDAA #%101110
STAA PUNC
*
* CLOSE PUNCH; PUNCH TRAILER.
*
PUNCLS LDAA #150
STAA STEPC
TRAIL CLRA
BSR PUNOUT
DEC STEPC
BNE TRAIL
BRA TR
SPC1
RDR EQU $8010 SWTPC PORT #4
RDRC EQU $8011
PUN EQU $8012
PUNC EQU $8013
PAG
*
* BUFFER ONE LINE FROM INPUT DEVICE
*
DELINE LDAA #$40
JSR OUTCH1 OUTPUT A 'AT' ON CTRL/X
JSR CRLF AND IGNORE WHOLE LINE.
INPSTR LDAA #'*
JSR OUTCH1 OUTPUT A PROMPT.
LDX #FIRSTC INIT BUFFER
CLR 0,X
NEXTCF CLR DELFLG
NEXTC STX CP
JSR INCH
CMPA #$18 CTRL/X (CAN)?
BEQ DELINE
CMPA #8 BACKSPACE?
BEQ DEL
CMPA #$7F DELETE?
BEQ DEL
STAA 1,X NO,STORE CHAR.
TST DELFLG AT END OF DEL. SEQUENCE?
BEQ NORML
LDAA #'] YES,CLOSE STRING OF
BSR OUTCH1 DELETED CHARACTERS.
NORML LDAA 1,X
BSR OUTCH1 ECHO TYPED CHAR.
CMPA #$D CR?
BEQ CR
CPX #LASTC NO,BUFFER FULL?
BEQ NEXTCF YES
INX
BRA NEXTCF
CR LDX #FIRSTC RESET BUFFER POINTER
STX CP
CLR CCOUNT
BSR OUTCH1 REFLECT CR & LF.
LDAA #$A
BSR OUTCH1
BRA GETC
DEL CPX #FIRSTC
BEQ NEXTC BUFFER UNDERFLOW!
DEX
CMPA #8
BEQ SHWDEL+2
TST DELFLG TYPE DELETED CHARACTERS
BNE SHWDEL ON 'DEL' ONLY.
LDAA #'[
STAA DELFLG
BSR OUTCH1
SHWDEL LDAA 1,X
BSR OUTCH1
BRA NEXTC
PAG
*
* GET ONE CHAR. FROM INPUT BUFFER
*
GETC LDX CP
LDAA 0,X GET CHARACTER FROM INPUT BUFFER
CMPA #$D END OF LINE?
BEQ INPSTR YES,GO READ NEXT LINE
LDAA 1,X NO,GET NEXT CHAR.
INX
STX CP
CMPA #', MAKE A 'SPACE' OF THE
BEQ SP FOLLOWING CHARACTERS:
CMPA #9 'COMMA' 'TAB' 'CARRIAGE RET.'
BEQ SP
CMPA #$D
BNE NOSP
SP LDAA #$20
NOSP RTS
*
* OUTPUT ONE CHAR.
*
OUTCH INC CCOUNT
CMPA #' SPACE?
BNE OUTCH1
LDAA CCOUNT YES,MORE THAN 55 CHAR. ON A LINE?
CMPA #55
BGT CRLF YES,OUTPUT A CR & LF.
LDAA #' NO
OUTCH1 STX TEMPX
LDX DEVICE
LDX 2,X
JSR 0,X
LDX TEMPX
RTS
*
* INPUT ONE CHARACTER
*
INCH STX TEMPX
LDX DEVICE
LDX 0,X
JSR 0,X
LDX TEMPX
RTS
PAG
*
* PRINT MESSAGE ON DEV #1
*
PMESSG STX MP
LDX N
BSR ASSIGN ASSIGN DEV #1
BSR CRLF
LDX MP
PMESG1 LDAA 0,X
BSR OUTCH PRINT STRING
TST 0,X
INX
BPL PMESG1
RTS
*
* NEW LINE
*
CRLF PSHA
LDAA #$D CARRIAGE RETURN
BSR OUTCH & LINE FEED ON TTY.
LDAA #$A
BSR OUTCH
CLR CCOUNT
PULA
RTS
PAG
*
* PUSH X ONTO STACK
*
PUSHX STX TEMPX
TSX
CPX LIMIT
BMI STKOVF STACK OVERFLOW!
LDAB 1,X SAVE RETURN ADDRESS
PSHB
LDAB 0,X
PSHB
LDAB TEMPX PLACE X ONTO STACK
STAB 0,X
LDAB TEMPX+1
STAB 1,X
LDX TEMPX
RTS
STKOVF LDX #SO.MS
JMP SYSERR
*
* PULL X FROM STACK
*
PULLX TSX
LDAB 2,X GET X FROM STACK
STAB TEMPX
LDAB 3,X
STAB TEMPX+1
PULB
STAB 2,X REPLACE RETURN ADDRESS
PULB
STAB 3,X
LDX TEMPX
RTS
PAG
*
* ASSIGN DEV. # TO INPUT AND OUTPUT HANDLER
* X MUST POINT TO AN NUMERIC ATOM.
* IF X IS NUL THE ASSIGN DEV #1
*
ASSIGN LDAB #1
STX SAVEX SAVE ATOM POINTER
BEQ DEV1
LDX 0,X
DEX
BNE ID.ER NON NUMERIC DEV. #
LDX SAVEX
LDX 2,X
LDAA 0,X
BNE ID.ER DEV. # > 256!
LDAB 1,X
BEQ ID.ER DEV. # = 0!
DEV1 LDX #DEVTBL-8
NXTDEV LDAA #8 OK SO FAR!
X8 INX
DECA
BNE X8
LDAA 0,X
BEQ ID.ER ZERO ENDS THE TABLE
DECB
BNE NXTDEV
STX DEVICE SET LINK ADDRESS
LDX ARG1
RTS
ID.ER LDX #ID.MS
JMP FATAL
*
* GET ONE CHAR. BUT SKIP SPACES.
*
GETCS JSR GETC
CMPA #'
BEQ GETCS
RTS
*
* PUT BACK ONE CHAR. IN INPUT BUFFER
*
PUTBAK LDX CP
DEX
STX CP
RTS
PAG
*
* (READ DEV)
*
*
READ BSR ASSIGN
READE BSR GETCS
CMPA #'(
BEQ S.EXPR EXPRESSION BEGINS WITH: (
CMPA #'.
BEQ SN.ER
CMPA #')
BEQ SN.ER . AND ) ARE ILLEGAL NOW
BSR PUTBAK
BRA READIE ATOMIC EXPRESSION.
SPC1
SN.ER LDX #SN.MS
FATAL JSR PMESSG
JMP LISP
SPC1
S.EXPR JSR GETCS
SPC2
CMPA #'.
BEQ SN.ER DOT IS ILLEGAL NOW!
SPC1
RDLIST LDX N EXPRESSION IS A LIST STRUCTURE.
CMPA #')
BEQ S.END
CMPA #'.
BEQ DOT DOT NOTATION.
BSR PUTBAK
BSR READE READ NEXT FORM
JSR PUSHX
BSR GETCS
BSR RELIST AND GO IN RDLIST AGAIN.
STX ARG2
JSR PULLX
STX ARG1
JSR CONS NOW CONS ALL FORMS TO A LIST
S.END RTS
SPC1
DOT BSR READE READ LAST FORM
STX ARG2
BSR GETCS
CMPA #') WHICH MUST BE CLOSED WITH: )
BNE SN.ER
LDX ARG2
RTS
PAG
*
* (READCH DEV)
* READ ONE CHARACTER FROM 'DEV'
*
READCH JSR ASSIGN
JSR GETC GET ONE CHAR.
LDX CP
STX PNAME
JMP AATOM AND BUILD AN ATOM OF IT.
SPC1
SN.ER1 JMP SN.ER
*
* (READ1 DEV)
* READ AN ATOM FROM 'DEV'.
*
READ1 JSR ASSIGN
READ1E JSR GETCS
LDX CP
STX PNAME 'PNAME' POINTS TO BEGIN OF ATOM
CMPA #''
BEQ SQUOTE
CMPA #'" ' AND " ARE SUPER-QUOTE CHAR.
BEQ SQUOTE
DEX
STX CP
RDATOM JSR GETC FIND END OF ATOM
CMPA #'(
BEQ ENDATM
CMPA #')
BEQ ENDATM
CMPA #'
BEQ ENDATM
CMPA #'.
BNE RDATOM
ENDATM JSR PUTBAK IF FIRST CHAR. IS + OR -
LDX PNAME OR 0-9 THEN ATOM IS NUMERIC.
DEX
CPX CP ANY ATOM?
BEQ SN.ER1 NO
INX
CLRB
LDAA 0,X
CMPA #'+
BEQ NATOM
TAB
CMPA #'-
BEQ NATOM
CLRB
CMPA #'0
BLT AATOM
CMPA #'9
BGT AATOM
DEX
PAG
*
* ATOM IS NUMERIC.
*
NATOM STAB SIGN
CLRA
CLRB
STAB NUM1
STAB NUM1+1
NXTDIG CPX CP END OF ATOM?
BEQ BLDNMB
INX
LDAA 0,X NO,GET NEXT DIGIT
CMPA #'0 AND CHECK IF 0-9.
BLT IN.ER
CMPA #'9
BGT IN.ER
ANDA #$F
STAA NUM2
LDAA NUM1 NOW SHIFT DIGIT INTO NUMBER
LDAB NUM1+1 JUST READ SO FAR.
ASLB
ROLA
ASLB
ROLA
ADDB NUM1+1
ADCA NUM1
ASLB
ROLA
ADDB NUM2
ADCA #0
STAA NUM1
STAB NUM1+1
BRA NXTDIG
BLDNMB TST SIGN
BEQ POSN
JSR NEG NEG. NUMBER IS TWO'S COMPL.
POSN JMP PUTIN
SPC1
IN.ER LDX #IN.MS
JMP FATAL
PAG
*
* ATOM IS SUPER QUOTED.
*
SQUOTE STAA SIGN SAVE QUOTE CHAR.
INX
STX PNAME
DEX
BQ INX
LDAA 0,X NOW READ ALL CHAR.
STX CP BETWEEN THE QUOTES.
CMPA #$D A CR ALSO DELIMITS THE QUOTING
BEQ AATOM
CMPA SIGN
BNE BQ
LDAA #' DELETE LAST QUOTE CHAR.
STAA 0,X IN THE BUFFER.
DEX
STX CP
INX
CPX PNAME IS THERE A QUOTED STRING?
BNE AATOM
LDX N NO, RETURN NIL
RTS
PAG
*
* ATOM IS ALPHA NUMERIC.
*
AATOM LDX #OBLIST
LDX 2,X
LDX 2,X GET VALUE OF OBLIST
STX NUM1
LDX 0,X
NXTOBJ STX OBLSTP
LDX 0,X GET ATOM FROM OBLIST
LDX 0,X AND GET ITS PRINTNAME
DEX
STX OP
LDX PNAME
STX AP
NXT2C LDX OP
BEQ NOMTCH
LDAA 0,X
LDAB 1,X GET 2 CHAR. FROM ATOM ON OBLIST
LDX 2,X
STX OP
LDX AP
CMPA 0,X AND COMPARE WITH 2 CHAR.
BNE NOMTCH OF ATOM IN INPUT BUFFER
CPX CP
BEQ MATCH
CMPB 1,X
BNE NOMTCH
INX
INX
STX AP
DEX
CPX CP
BNE NXT2C
LDX OP
BNE NOMTCH
LDAB #F
MATCH CMPB #F
BNE NOMTCH
LDX OBLSTP ATOM IS ON THE OBLIST
LDX 0,X RETURN ITS POINTER AS VALUE.
RTS
PAG
NOMTCH LDX OBLSTP NO MATCH SO FAR.
LDX 2,X TAKE NEXT ATOM FROM OBLIST.
BNE NXTOBJ
*
* ATOM NOT ON OBLIST
*
STX ARG1
STX ARG2
JSR CONS BUILD ATOM CELL
STX ARG3
LDX CP
INX
STX AP
LDAA PNAME+1
EORA AP+1
RORA
BCC BLDATM EVEN NUMBER OF CHAR.
JSR CONS
STX ARG2 ODD NUMBER OF CHAR.
LDX AP SO ADD A FILL CHAR.
LDAB #F
BRA ODD
BLDATM JSR CONS NOW BUILD AN ATOM,
STX ARG2 WITH 2 CHAR. PER CELL
LDX AP
DEX
LDAB 0,X
ODD DEX
LDAA 0,X
STX AP
LDX ARG2
STAA 0,X
STAB 1,X
LDX ARG3
JSR RPLACA UPDATE ATOM-CELL
INC 1,X AND SET ATOM-MARK
LDX AP
CPX PNAME
BNE BLDATM
LDX ARG3 AND ADD IT ON TOP OF THE OBLIST
STX ARG1
LDX NUM1
LDX 0,X
STX ARG2
JSR CONS
STX ARG2
LDX NUM1
JSR RPLACA UPDATE OBLIST!
LDX ARG3 VALUE IS THE NEW ATOM
RTS
PAG
*
* (OPEN DEV FILENAME)
*
* OPEN A FILE ON 'DEV' WITH 'FILENAME'.
* ON NON FILE ORIENTED DEVICES,
* THIS CALL ONLY INITIALIZES THE HANDLER
*
OPEN JSR ASSIGN
LDX DEVICE GET OPEN-LINK FOR 'DEV'
LDX 4,X
JMP 0,X AND GO TO REQUESTED HANDLER
*
* (CLOSE DEV)
*
* CLOSE FILE ON 'DEV'
*
CLOSE JSR ASSIGN
LDX DEVICE
LDX 6,X
JMP 0,X
PAG
*
* (PRINT X DEV)
*
PRINT LDX ARG2
JSR ASSIGN
PRINTE CLRA
PSHA BOTTOM OF STACK IS NIL.
PSHA
SPC1
PRINT2 STX ARG1
JSR ATOM ATOMIC?
BEQ PRINT7 NO
LDX ARG1
BSR PRIN1E YES,PRINT ATOM
PRINT3 JSR PULLX
BNE PRINT4
RTS
SPC1
PRINT4 LDX 2,X GET CDR-PART
STX ARG1
BEQ PRINT5
JSR ATOM CDR PART ATOMIC?
BEQ PRINT6 NO
LDAA #'
JSR OUTCH
LDAA #'.
JSR OUTCH YES,PRINT A DOT
LDAA #'
JSR OUTCH
LDX ARG1
BSR PRIN1E AND PRINT ATOM
SPC1
PRINT5 LDAA #')
JSR OUTCH
BRA PRINT3
SPC1
PRINT6 LDAA #'
FCB $8C SKIP
SPC1
PRINT7 LDAA #'(
JSR OUTCH
LDX ARG1
JSR PUSHX
LDX 0,X
BRA PRINT2
PAG
*
* (PRIN1 X DEV)
*
* PRINT 'PRINTNAME' OF ATOM X
* OR NUMERIC VALUE IN CASE OF A NUMBER
*
PRIN1 LDX ARG2
JSR ASSIGN
PRIN1E JSR ABORT
LDX ARG1
LDAA 1,X
RORA
BCC NA.ER NOT ATOMIC
LDX 0,X GET LINK TO PRINT NAME
DEX CLEAR ATOM MARK
BEQ PRNMB NUMERIC!
PRCHAR LDAA 0,X PRINT CHAR. STRING UNTIL
JSR OUTCH FILL CHAR. OR NIL
LDAA 1,X
BMI DONE
JSR OUTCH
DONE LDX 2,X
BNE PRCHAR
RTS VALUE OF PRIN1 IS NIL
PAG
*
* ATOM IS NUMERIC
*
PRNMB LDX ARG1
LDX 2,X GET NUMBER
LDAB 1,X
LDAA 0,X
BPL POS
LDAA #'- NEGATIVE NUMBER,
JSR OUTCH PRINT MINUS SIGN
LDAA 0,X
LDAB 1,X
JSR NEG AND NEGATE NUMBER
POS LDX #DECTBL
CLR AP
DEC1 CLR SIGN BINARY TO DEC CONVERSION.
DEC2 INC SIGN WITH LEADING ZERO SUPPRESSION.
SUBB 1,X
SBCA 0,X
BPL DEC2
ADDB 1,X
ADCA 0,X
PSHA
PSHB
LDAA SIGN
DECA
BNE DEC3
TST AP
BEQ DEC4 LEADING ZERO
DEC3 ADDA #'0 MAKE ASCII
STAA AP
JSR OUTCH AND PRINT
DEC4 INX
INX
PULB
PULA
TST 1,X AT END OF TABLE?
BNE DEC1
TBA
ADDA #'0 YES,PRINT LAST DIGIT.
JSR OUTCH
BRA FALSE
SPC1
DECTBL FDB 10000,1000,100,10,0
SPC1
NA.ER LDX #NA.MS
PNTARG JSR PMESSG
LDX ARG1
JSR PRINTE PRINT ARGUMENT
BRA TERPRI
PAG
*
* (ATOM X)
*
* IF X IS ATOMIC THEN TRUE ELSE NIL
*
ATOM LDAA 1,X
RORA
BCS TRUE CELL IS ATOMCI
FALSE LDX N
RTS
*
* (NUMBER X)