2 TITLE READER FOR MUDDLE
8 READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS
9 FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST
13 .GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,TENTAB,CHMAK,FLUSCH,ITENTB
14 .GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR
18 FF=0 ;FALG REGISTER DURING NUMBER CONVERSION
20 ;FLAGS USED (RIGHT HALF)
22 NOTNUM==1 ;NOT A NUMBER
23 NFIRST==2 ;NOT FIRST CHARACTER BEING READ
24 DECFRC==4 ;FORCE DECIMAL CONVERSION
25 NEGF==10 ;NEGATE THIS THING
26 NUMWIN==20 ;DIGIT(S) SEEN
27 INSTRN==40 ;IN QUOTED CHARACTER STRING
28 FLONUM==100 ;NUMBER IS FLOOATING POINT
29 DOTSEN==200 ;. SEEN IN IMPUT STREAM
30 EFLG==400 ;E SEEN FOR EXPONENT
32 FRSDOT==1000 ;. CAME FIRST
33 USEAGN==2000 ;SPECIAL DOT HACK
38 VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR
39 ONUM==1 ;CURRENT NUMBER IN OCTAL
40 DNUM==3 ;CURRENT NUMBER IN DECIMAL
41 FNUM==5 ;CURRENTLY UNUSED
42 CNUM==7 ;IN CURRENT RADIX
43 NDIGS==11 ;NUMBER OF DIGITS
47 \f; TEXT FILE LOADING PROGRAM
53 HLRZ A,AB ;GET NO. OF ARGS
55 JRST TRY2 ;NO, TRY ANOTHER
56 HLRZ A,2(AB) ;GET TYPE
57 CAIE A,TOBLS ;IS IT OBLIST
61 TRY2: CAIE A,-2 ;IS ONE SUPPLIED
64 CHECK1: HLRZ A,(AB) ;GET TYPE
65 CAIE A,TCHAN ;IS IT A CHANNEL
68 LOAD1: HLRZ A,TB ;GET CURRENT TIME
69 PUSH TP,$TTIME ;AND SAVE IT
72 LOAD2: PUSH TP,(TB) ;USE TIME AS EOF ARG
74 PUSH TP,(AB) ;USE SUPPLIED CHANNEL
77 CAML AB,[-2,,0] ;CHECK FOR 2ND ARG
80 PUSH TP,2(AB) ;PUSH ON 2ND ARG
83 JRST CHKRET ;CHECK FOR EOF RET
86 CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK
87 CAME B,1(TB) ;AND IS VALUE
88 JRST EVALIT ;NO, GO EVAL RESULT
103 ; OTHER FILE LOADING PROGRAM
106 \fMFUNCTION FLOAD,SUBR
110 MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT
111 PUSH TP,$TAB ;SLOT FOR SAVED AB
112 PUSH TP,[0] ;EMPTY FOR NOW
113 PUSH TP,$TCHSTR ;PUT IN FIRST ARG
115 MOVE A,AB ;COPY OF ARGUMENT POINTER
117 FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN
118 HLRZ B,(A) ;NO, CH
\0ECK TYPE OF THIS ARG
119 CAIN B,TOBLS ;OBLIST?
120 JRST OBLSV ;YES, GO SAVE IT
122 PUSH TP,(A) ;SAVE THESE ARGS
125 AOJA C,FARGS ;COUNT AND GO
127 OBLSV: MOVEM A,1(TB) ;SAVE THE AB
129 CALOPN: ACALL C,FOPEN ;OPEN THE FILE
131 JUMPE B,FNFFL ;FILE MUST NO EXIST
132 EXCH A,(TB) ;PLACE CHANNEL ON STACK
133 EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST
134 JUMPN B,2ARGS ;OBLIST SUOPPLIED?
136 MCALL 1,LOAD ;NO, JUST CALL
140 2ARGS: PUSH TP,(B) ;PUSH THE OBLIST
146 FNFFL: PUSH TP,$TATOM
147 PUSH TP,MQUOTE FILE-NOT-FOUND
150 \fMFUNCTION RREADC,SUBR,READCHR
153 PUSH P,[IREADC] ;WHERE TO GO AFTER BINDING
154 JRST READ0 ;GO BIND VARIABLES
156 MFUNCTION NXTRDC,SUBR,NEXTCHR
167 PUSH P,[IREAD1] ;WHERE TO GO AFTER BINDING
168 READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE)
170 PUSH TP,$TFIX ;SLOT FOR RADIX
172 PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL
174 JUMPGE AB,READ1 ;NO ARGS, NO BINDING
175 MOVE B,AB ;GET A COPY OF THE ARG BLOCK
176 MOVEI D,0 ;ACCESS ARG TABLE
177 ARGLP: HLRZ C,(B) ;ISOLATE TYPE
178 XCT ARGS(D) ;DO THE APROPRIATE COMPARE
180 PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
182 PUSH TP,(B) ;PUSH ARGS
186 ADDI D,2 ;BUMP ARG TBL POINTER
187 ADD B,[2,,2] ;AND ARG POINTER
190 PUSHJ P,SPECBIND ;NO, GO BIND
193 \f; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS
195 READ1: MOVE B,MQUOTE INCHAN,, ;GET INPUT CHANNEL
197 PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL
198 CAME A,$TCHAN ;IS IT A CHANNEL
200 MOVEM B,5(TB) ;SAVE CHANNEL
201 MOVEI B,DIRECT-1(B) ;POINT TO DIRECTION
202 PUSHJ P,CHRWRD ;GOBBLE AND CHECK
204 CAME B,[ASCIZ /READ/]
207 GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION
208 JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK
209 MOVE A,RADX(B) ;GET RADIX
211 MOVEM B,5(TB) ;SAVE CHANNEL
212 REREAD: MOVE D,LSTCH(B) ;ANY CHARS AROUND?
213 CAIN D,233 ;FLUSH THE TERMINATOR HACK
216 PUSHJ P,@(P) ;CALL INTERNAL READER
218 RFINIS: MOVE C,5(TB) ;GET CHANNEL
219 MOVE D,LSTCH(C) ;GET LAST CHR
220 CAIN D,233 ;SPECIAL ENDER?
221 SETZM LSTCH(C) ;YES CLOBBER
222 SUB P,[1,,1] ;POP OFF LOSER
225 BADTRM: CAIE B,3 ;READ 'FAILED' IS LOSER EOF
226 JRST CHLSTC ;NO, MUST BE UNMATCHED PARENS
227 PUSH TP,4(TB) ;CLOSE THE CHANNEL
230 MOVE B,MQUOTE EOF,, ;GET EOF
232 PUSHJ P,IDVAL ;GET LOCAL VALUE
233 CAMN A,$TUNBOU ;UNBOUND IS ONLY LOSER
235 PUSH TP,A ;SETUP CALL TO EVAL
237 MCALL 1,EVAL ;AND EVAL IT
238 JRST RFINIS ; AND RETURN
240 ;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL
242 OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN
243 JUMPE B,OPNERR ;LOSE IC B IS 0
247 CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK
250 \f;MAIN ENTRY TO READER
253 PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER
255 PUSH TP,(TB) ;SAVE LAST FORM
257 BDLP: PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D
259 JUMPN B,@.+1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE
261 DTBL: NUMLET ;HERE IF NUMBER OR LETTER
268 NONSPC==.-DTBL ;NUMBER OF NON-SPECIAL CHARACTERS
269 SPACE ;SPACING CHAR CR,LF,SP,TAB ETC.
270 SPATYP==.-DTBL ;TYPE FOR SPACE CHARS
273 ;THE FOLLOWING ENTRIES ARE VARIOUS PUNCTUATION CROCKS
275 LPAREN ;( - BEGIN LIST
276 RPAREN ;) - END CURRENT LEVEL OF INPUT
277 LBRACK ;[ -BEGIN ARRAY
279 RBRACK ;] - END OF ARRAY
280 QUOTIT ;' - QUOTE THE FOLLOWING GOODIE
283 MACCAL ;% - INVOKE A READ TIME MACRO
285 CSTRING ;" - CHARACTER STRING
287 NUMLET ;\ - ESCAPE,BEGIN ATOM
289 ESCTYP==.-DTBL ;TYPE OF ESCAPE CHARACTER
291 SPECTY ;# - SPECIAL TYPE TO BE READ
292 OPNANG ;< - BEGIN ELEMENT CALL
294 SLMNT==.-DTBL ;TYPE OF START OF SEGMENT
296 CLSANG ;> - END ELEMENT CALL
299 EOFCHR ;^C - END OF FILE
301 COMNT ;; - BEGIN COMMENT
303 GLOVAL ;, - GET GLOBAL VALUE
310 ; EXTENDED TABLE FOR ! HACKS
312 SEGDOT ;!. - CALL TO LVAL (SEG)
314 UVECIN ;![ - INPUT UNIFORM VECTOR ]
316 QUOSEG ;!' - SEG CALL TO QUOTE
318 SINCHR ;!" - INPUT ONE CHARACTER
322 GLOSEG ;!, - SEG CALL TO GVAL
324 TERM ;!$ - (EXCAL-ALT MODE) PUT ALL CLOSES
330 SPACE: PUSHJ P,LSTCHR ;DONT REREAD SPACER
334 ;HERE ON NUMBER OR LETTER, START ATOM
336 NUMLET: PUSHJ P,GOBBLE ;READ IN THE ATOM AND PUT PNTR ON ARG PDL
337 JRST RET ;NO SKIP RETURN I.E. NON NIL
339 ;HERE TO START BUILDING A CHARACTER STRING GOODIE
341 CSTRING: PUSHJ P,GOBBL1 ;READ IN STRING
344 ;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION
346 MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER
347 CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR
349 JRST MACAL1 ;NO, CALL MACRO AND USE VALUE
350 PUSHJ P,LSTCHR ;DONT REREAD %
351 PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE
355 MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME
356 PUSHJ P,ERRPAR ;BAD PARENS
357 PUSH TP,A ;SAVE THE RESULT
358 PUSH TP,B ;AND USE IT AS AN ARGUMENT
362 ;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT
364 SPECTY: PUSHJ P,IREAD ;READ THE TYPES NAME (SHOULD BE AN ATOM)
366 PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL
368 PUSHJ P,IREAD1 ;NOW READ STRUCTURE
369 PUSHJ P,ERRPAR ;LOSSAGE
370 EXCH A,-1(TP) ;USE AS FIRST ARG
372 PUSH TP,A ;USE OTHER AS 2D ARG
374 MCALL 2,CHTYPE ;ATTEMPT TO MUNG
377 ;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS
378 ;BETWEEN (), ARRIVED AT WHEN ( IS READ
383 OPNANG: PUSH TP,$TFORM ;SAVE TYPE
388 PUSH TP,$TLIST ;START BY ASSUMING NIL
390 PUSHJ P,LSTCHR ;DON'T REREAD PARENS
391 LLPLOP: PUSHJ P,IREAD1 ;READ IT
392 JRST LDONE ;HIT TERMINATOR
394 ;HERE WHEN MUST ADD CAR TO CURRENT WINNER
396 GENCAR: PUSH TP,A ;SAVE TYPE OF VALUE
398 MCALL 1,NCONS ;GOBBLE NIL LISTE
399 MOVEM A,(TB) ;SAVE AWAY
400 MOVEM B,1(TB) ;FOR COMMENT
402 JUMPN C,CDRIN ;IF STACKED GOODIE NOT NIL SKIP
403 MOVE C,(TP) ;FIX UP LAT TYPE
405 PUSH TP,B ;AND USE AS TOTAL VALUE
406 PUSH TP,A ;SAVE THIS AS FIRSST THING ON LIST
407 JRST .+2 ;SKIP CDR SETTING
409 PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE
410 JRST LLPLOP ;AND CONTINUE
412 ; HERE TO RAP UP LIST
414 LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER
415 PUSHJ P,MISMAT ;REPORT MISMATCH
417 POP TP,B ;GET VALUE OF PARTIAL RESULT
418 POP TP,A ;AND TYPE OF SAME
419 JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN
420 POP TP,B ;POP FIRST LIST ELEMENT
424 ;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS
425 UVECIN: PUSH P,[EUVECTOR] ;PUSH NAME OF U VECT HACKER
428 LBRACK: PUSH P,[EVECTOR] ;PUSH GEN VECTOR HACKER
429 LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR
430 PUSH P,[0] ;INITIALIZE TO (WILL COUNT VECTOR ELEMENTS)
432 LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY
433 JRST LBDONE ;RAP UP ON TERMINATOR
435 STAKIT: PUSH TP,A ;SAVE RESULT TYPE
437 AOS VCNT(P) ;AND COUNT
440 ; HERE TO RAP UP VECTOR
442 LBDONE: CAIE B,"] ;FINISHED RETURN (WAS THE RIGHT STOP USED?)
443 PUSHJ P,MISMAB ;WARN USER
445 ACALL A,@-1(P) ;MAKE THE VECTOR
450 ; BUILD A SINGLE CHARACTER ITEM
452 SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT
453 CAIN B,ESCTYP ;ESCAPE?
455 LSHC A,29.-36. ;POSITION IN B
460 ; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C
462 CLSANG: ;CLOSE ANGLE BRACKETS
463 RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO
464 RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD
465 EOFCHR: MOVE B,A ;GETCHAR IN B
466 MOVSI A,TCHRS ;AND TYPE IN A
469 ; NORMAL RETURN FROM IREAD/IREAD1
471 RETCL: PUSHJ P,LSTCHR ;DONT REREAD
473 RET1: POP TP,1(TB) ;SAVE LAST READ CROCK
478 ;RANDOM MINI-SUBROUTINES USED BY THE READER
480 ;READ A CHAR INTO A AND TYPE CODE INTO D
482 NXTC1: MOVE B,5(TB) ;GET CHANNEL
484 NXTC: MOVE B,5(TB) ;GET CHANNEL
485 SKIPN A,LSTCH(B) ;CHAR IN A IF REUSE
486 NXTC2: XCT IOINS(B) ;GET CHARACTER FROM INPUT
487 ANDI A,377 ;INCASE IT IS EOF
488 MOVEM A,LSTCH(B) ;SAVE THE CHARACTER
489 TRZE A,200 ;DONT SKIP IF SPECIAL
490 JRST RETYPE ;GO HACK SPECIALLY
491 GETCTP: PUSH P,A ;AND SAVE FROM DIVISION
492 IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER
493 LDB B,BYTPNT(B) ;GOBBLE TYPE CODE
497 ; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK !
500 NXTCH1: PUSHJ P,NXTC1 ;READ CHAR
502 NXTCH: PUSHJ P,NXTC ;READ CHAR
503 CAIE B,NTYPES+1 ;IF 1 > THAN MAX, MUST BE SPECIAL
504 POPJ P, ;OTHERWISE JUST RETURN
506 PUSHJ P,NXTC1 ;READ NEXT ONE
508 JRST UPLO ;YES, INVERT CASE
509 RETYP1: CAIN B,DOTTYP ;!.
510 MOVEI B,DOTEXT ;YES, GET EXTENDED TYPE
511 CAIN B,LBRTYP ;DO FOR ALL SPECIALS
521 CAIN B,SPATYP ;SPACER?
522 JRST CHKALT ;YES, CHECK IT
524 CRMLST: ADDI A,200 ;CLOBBER LASTCHR
526 MOVE B,5(TB) ;POINT TO CHANNEL
528 SUBI A,200 ;DECREASE CHAR
532 UPLO: ADDI A,40 ;CHANGE CASE OF LETTER IN A
537 RETYPE: PUSHJ P,GETCTP ;GET TYPE OF CHAR
541 CHKALT: CAIN A,33 ;ALT?
546 TERM: MOVEI B,0 ;RETURN A 0
551 ;TABLE OF BYTE POINTERS FOR GETTING CHARS
553 BYTPNT": 350700,,CHTBL(A)
559 ;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS
560 ;IN THE NUMBER LETTER CATAGORY)
562 SETCHR 2,[0123456789]
570 SETCOD 6,[15,12,11,14,40,33] ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE)
572 INCRCH 7,[()[]'%"\#<>] ;GIVE THESE INCREASRNG CODES FROM 3
574 SETCOD 22,[3] ;^C - EOF CHARACTER
576 INCRCH 23,[;,!] ;COMMENT AND GLOBAL VALUE AND SPECIAL
579 OUTTBL ;OUTPUT THE TABLE RIGHT HERE
583 ; THIS CODE ASSOCIATES A COMMENT WITH THE LAST READ GOODIE
585 COMNT: HLRZ A,(TB) ;CHECK THERE IS AN ITEM TO COMMENT
586 CAIN A,TTP ;TYPE TP MEANS NONE THERE
588 PUSH TP,(TB) ;SAVE THEM
590 MOVSI A,TTP ;RESET LAST GOODIE
593 PUSHJ P,IREAD ;CALL READER FLUSHING ,
596 PUSH TP,MQUOTE COMMENT
597 PUSH TP,A ;PUSH THE COMMENT
599 MCALL 3,PUT ;PUT THE COMMENT ON
602 ; THIS CODE FLUSHES WANDERING COMMENTS
604 NOCMNT: PUSHJ P,IREAD
608 ;SUBROUTINE TO READ CHARS ONTO STACK
610 GOBBL1: MOVEI FF,0 ;KILL ALL FLAGS
611 PUSHJ P,LSTCHR ;DON'T REREAD "
612 TROA FF,NOTNUM+INSTRN ;SURPRESS NUMBER CONVERSION
613 GOBBLE: MOVEI FF,0 ;FLAGS CONCERRNING CURRENT GOODIE IN HERE
614 MOVE A,TP ;GOBBLE CURRENT TP TO BE PUSHED
615 MOVEI C,6 ;NOW PUSH 6 0'S ON TO STACK
616 PUSH TP,$TFIX ;TYPE IS FIXED
617 PUSH TP,FF ;AND VALUE IS 0
618 SOJG C,.-2 ;FOUR OF THEM
619 PUSH TP,$TTP ;NOW SAVE OLD TP
620 ADD A,[1,,1] ;MAKE IT LOOK LIKE A TB
622 MOVEI D,0 ;ZERO OUT CHARACTER COUNT
623 GOB1: MOVEI C,0 ;SET UP FIRST WORD OF CHARS
624 PUSH P,[440700,,C] ;BYTE POINTER
625 GOB2: PUSH P,FF ;SAVE FLAG REGISTER
626 PUSHJ P,NXTCH ;READ A CHAACTER
627 POP P,FF ;AND RESTORE FLAG REGISTER
628 CAIN B,ESCTYP ;IS IT A CHARACTER TO BE ESCAPED
629 JRST ESCHK ;GOBBLE THE ESCAPED CHARACTER
630 TRNE FF,INSTRN ;ARE WE BUILDING A CHAR STRING
631 JRST ADSTRN ;YES, GO READ IN
632 CAILE B,NONSPC ;IS IT SPECIAL
633 JRST DONEG ;YES, RAP THIS UP
635 TRNE FF,NOTNUM ;IS NUMERIC STILL WINNING
636 JRST SYMB2 ;NO, ONLY DO CHARACTER HACKING
637 CAIL A,60 ;CHECK FOR DIGIT
639 JRST SYMB1 ;NOT A DIGIT
640 JRST CNV ;GO CONVERT TO NUMBER
643 ;ARRIVE HERE IF STILL BUILDING A NUMBER
644 CNV: MOVE B,(TP) ;GOBBLE POINTER TO TEMPS
645 TRO FF,NUMWIN ;SAY DIGITSSEEN
646 SUBI A,60 ;CONVERT TO A NUMBER
647 TRNE FF,EFLG ;HAS E BEEN SEEN
648 JRST ECNV ;YES, CONVERT EXPONENT
649 TRNE FF,DOTSEN ;HAS A DOT BEEN SEEN
651 JRST DECNV ;YES, THIS IS A FLOATING NUMBER
653 JFCL 17,.+1 ;KILL ALL FLAGS
654 MOVE E,CNUM(B) ;COMPUTE CURRENT RADIX
656 ADD E,A ;ADD IN CURRENT DIGIT
658 MOVEM E,CNUM(B) ;AND SAVE IT
662 ;INSERT OCTAL AND CRADIX CROCK HERE IF NECESSSARY
663 JRST DECNV1 ;CONVERT TO DECIMAL(FIXED)
666 DECNV: TRO FF,FLONUM ;SET FLOATING FLAG
667 DECNV1: JFCL 17,.+1 ;CLEAR ALL FLAGS
668 MOVE E,DNUM(B) ;GET DECIMAL NUMBER
670 JFCL 10,CNV2 ;JUMP IF OVERFLOW
671 ADD E,A ;ADD IN DIGIT
673 TRNE FF,FLONUM ;IS THIS FRACTION?
674 SOS NDIGS(B) ;YES, DECREASE EXPONENT BY ONE
676 CNV1: PUSHJ P,NXTCH ;RE-GOBBLE CHARACTER
677 JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE
\rîCNV2: ;OVERFLOW IN DECIMAL NUMBER
678 TRNE FF,DOTSEN ;IS THIS FRACTION PART?
679 JRST CNV1 ;YES,IGNORE DIGIT
680 AOS NDIGS(B) ;NO, INCREASE IMPLICIT EXPONENT BY ONE
681 TRO FF,FLONUM ;SET FLOATING FLAG BUT
682 JRST CNV1 ;DO NOT FORCE DECIMAL(DECFRC)
684 ECNV: ;CONVERT A DECIMAL EXPONENT
685 HRRZ E,ENUM(B) ;GET EXPONENT
687 ADD E,A ;ADD IN DIGIT
688 TLNN E,777777 ;IF OVERFLOW INTO LEFT HALF
689 HRRM E,ENUM(B) ;DO NOT STORE(CATCH ERROR LATER)
691 JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE
694 ;HERE TO PUT INTO IDENTIFIER BEING BUILT
696 ESCHK: PUSHJ P,NXTC1 ;GOBBLE NEXT CHAR
697 SYMB: MOVE B,(TP) ;GET BACK TEM POINTER
698 TRNE FF,EFLG ;IF E FLAG SET
699 HLRZ FF,ENUM(B) ;RESTORE SAVED FLAGS
700 TRO FF,NOTNUM ;SET NOT NUMBER FLAG
701 SYMB2: TRO FF,NFIRST ;NOT FIRST IN WORLD
702 SYMB3: IDPB A,(P) ;INSERT IT
703 PUSHJ P,LSTCHR ;READ NEW CHARACTER
704 TRNN C,377 ;WORD FULL?
705 JRST GOB2 ;NO, KEEP TRYING
706 MOVEM C,(P) ;YES,STORE IT
707 AOJA D,GOB1 ;COUNT WORD AND GO
709 ;HERE TO CHECK FOR +,-,. IN NUMBER
711 SYMB1: TRNE FF,NFIRST ;IS THIS THE FIRST CHARACTER
712 JRST CHECK. ;NO, ONLY LOOK AT DOT
713 CAIE A,"- ;IS IT MINUS
714 JRST .+3 ;NO CHECK PLUS
715 TRO FF,NEGF ;YES, NEGATE AT THE END
718 JRST SYMB2 ;ESSENTIALLY IGNORE IT
722 CHECK.: PUSHJ P,LSTCHR ;FLUSH LAST CHARACTER
724 TRNN FF,DOTSEN+EFLG ;IF ONE ALREADY SEEN
726 JRST CHECKE ;GO LOOK FOR E
729 TRNN FF,NFIRST ;IS IT THE FIRST
730 JRST DOT1 ;YES, COULD MEAN EVALUATE A VARIABLE
733 CHCK.1: TRO FF,DECFRC+DOTSEN ;FORCE DECIMAL
734 IFN FRMSIN, TRNN FF,FRSDOT ;IF NOT FIRST ., PUT IN CHAR STRING
735 JRST SYMB2 ;ENTER INTO SYMBOL
736 IFN FRMSIN, JRST GOB2 ;IGNORE THE "."
742 ;HERE TO SET UP FOR .FOO ..FOO OR.<ABC>
744 DOT1: PUSH P,FF ;SAVE FLAGS
745 PUSHJ P,NXTCH1 ;GOBBLE A NEW CHARACTER
746 POP P,FF ;RESTORE FLAGS
747 TRO FF,FRSDOT ;SET FLAG IN CASE
748 CAIN B,NUMCOD ;SKIP IF NOT NUMERIC
749 JRST CHCK.1 ;NUMERIC, COULD BE FLONUM
751 ; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL
755 SUB P,[2,,2] ;POP OFF BYTE POINTER AND GOBBLE CALL
757 SUB TP,[1,,1] ;REMOVE TP JUNK
760 GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL
761 GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME
765 QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE
766 QUOTIT: MOVSI B,TFORM
770 SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL
772 IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT
773 IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR
778 IMPCA2: PUSH TP,A ;PUSH RESULTS
780 MCALL 2,LIST ;MAKE THE LIST
781 POP P,A ;GET FINAL TYPE
785 ;HERE AFTER READING ATOM TO CALL VALUE
787 .SET: SUB P,[1,,1] ;FLUSH GOBBLE CALL
788 PUSH P,$TFORM ;GET WINNING TYPE
789 .SET1: PUSH TP,$TATOM
791 JRST IMPCA2 ;GO CONS LIST
795 ;HERE TO CHECK FOR "E" FLAVOR OF EXPONENT
797 CHECKE: TRNN FF,EFLG ;HAS ONE BEEN SEEN
798 CAIE A,"E ;IF NOT, IS THIS ONE
799 JRST SYMB ;NO, ENTER AS SYMBOL KILL NUMERIC WIN
801 TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN?
802 JRST SYMB ;NO, NOT A NUMBER
803 MOVE B,(TP) ;GET POINTER TO TEMPS
804 HRLM FF,ENUM(B) ;SAVE FLAGS
805 HRRI FF,DECFRC+DOTSEN+EFLG ;SET NEW FLAGS
806 JRST SYMB3 ;ENTER SYMBOL
809 ;HERE ON READING CHARACTER STRING
811 ADSTRN: CAIN B,MANYT ;TERMINATE?
813 CAIE A,"" ;QUOTE CHAR?
814 JRST SYMB2 ;NO JUST INSERT IT
815 ADSTN1: PUSHJ P,LSTCHR ;DON'T REREAD """
818 ;HERE TO FINISH THIS CROCK
820 DONEG: TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN?
821 TRO FF,NOTNUM ;NO,SET NOT NUMBER FLAG
822 POP P,A ;FLUSH POINT BYTER
823 JUMPE C,.+3 ;LAST WORD USED?
824 PUSH P,C ;YES, STORE IT
825 AOS D ;AND BUMP COUNT
827 TRNN FF,NOTNUM ;NUMERIC?
828 JRST NUMHAK ;IS NUMERIC, GO TO IT
831 MOVE A,(TP) ;GET POINTER TO TEMPS
832 MOVEM FF,NDIGS(A) ;USE TO HOLD FLAGS
834 TRNE FF,INSTRN ;ARE WE BUILDING A STRING
835 JRST MAKSTR ;YES, GO COMPLETE SAME
836 MOVSI A,TATOM ;GET AATOM TYPE
837 MOVE B,MQUOTE OBLIST,
838 PUSHJ P,IDVAL ;GET VALUE
842 MOVE C,(TP) ;SET TO REGOBBLE FLAGS
847 ;HERE TO RAP UP CHAR STRING ITEM
849 MAKSTR: MOVE C,D ;SETUP TO CALL CHMAK
850 PUSHJ P,CHMAK ;GO MAKE SAME
854 NUMHAK: MOVE C,(TP) ;REGOBBLETEMP POINTER
855 POP P,D ;POP OFF STACK TOP
856 HRLI D,(D) ;TOO BOTH HALVES
857 SUB P,D ;REMOVE CHAR STRING
858 TRNE FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER
859 JRST FLOATIT ;YES, GO MAKE IT WIN
862 MOVE B,DNUM(C) ;GRAB FIXED GOODIE
863 \rFINID2: MOVSI A,TFIX ;SAY FIXED POINT
864 FINID1: TRNE FF,NEGF ;NEGATE
866 FINID: POP TP,TP ;RESTORE OLD TP
867 SUB TP,[1,,1] ;FINISH HACK
869 TRNE FF,FRSDOT ;DID . START IT
870 JRST .SET ;YES, GO HACK
875 \fFLOATIT:î JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS
876 \r TRNE FF,EFLG ;"E" SEEN?
877 JRST EXPDO ;YES, DO EXPONENT
878 MOVE D,NDIGS(C) ;GET IMPLICIT EXPONENT
880 FLOATE: MOVE A,DNUM(C) ;GET DECIMAL NUMBER
\0
881 IDIVI A,400000 ;SPLIT
882 FSC A,254 ;CONVER
\0T MOST SIGNIFICANT
883 FSC B,233 ; AND LEAST SIGNIFICANT
886 MOVM A,D ;GET MAGNITUDE OF EXPONENT
887 CAILE A,37. ;HOW BIG?
888 JRST FOOR ;TOO BIG-FLOATING OUT OF RANGE
889 JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE
890 FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT
893 FLOAT1: FMPR B,TENTAB(A) ;SCALE UP
895 SETFLO: JFCL 10,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW
897 IFN FRMSIN, TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE
901 HRRZ D,ENUM(C) ;GET EXPONENT
902 TRNE FF,NEGF ;IS EXPONENT NEGATIVE?
904 ADD D,NDIGS(C) ;ADD IMPLICIT EXPONENT
905 HLR FF,ENUM(C) ;RESTORE FLAGS
906 JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE
907 CAIG D,10. ;OR IF EXPONENT TOO LARGE
908 TRNE FF,FLONUM ;OR IF FLAG SET
912 JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING
913 JRST FINID2 ;GO MAKE FIXED NUMBER
915 ; HERE TO READ ONE CHARACTER FOR USER.
917 INXTRD: SKIPA E,[JFCL] ;NULL CLEAR INS
918 IREADC: MOVE E,[PUSHJ P,LSTCHR] ;AVOID RE-READ
919 PUSHJ P,NXTC ;GOBBLE THE CHAR
920 XCT E ;CLEAR LSTCHR IF NECESSARY
922 JRST EOFCHR ;DO EOF RETURN
924 LSH B,29. ;LEFT JUSTIFY
925 MOVSI A,TCHRS ;AND TYPE
928 ; READER ERRORS COME HERE
930 ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER
931 LSH B,29. ;POSITION IN WORD
934 PUSH TP,[40_29.] ;SPACE
936 PUSH TP,MQUOTE WARNING-UNMATCHED
940 PUSHJ P,LSTCHR ;FLUSH THE CHARACTER
941 SOS (P) ;SIMULATE JRST .-1
945 ;COMPLAIN ABOUT MISMATCHED CLOSINGS
948 MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER
949 JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE
954 PUSH TP,MQUOTE [ INSTEAD-OF ]
965 ; HERE TO RESET A READ CHANNEL
967 MFUNCTION RRRES,SUBR,RESET
973 MOVE C,1(AB) ;GET CHANNEL
974 MOVEI B,DIRECT-1(C) ;POINT TO DIRECTION
975 PUSHJ P,CHRWRD ;CONVER T TO A WORD
977 CAME B,[ASCII /READ/]
979 MOVE B,1(AB) ;RESTORE CHANNEL
981 PUSHJ P,RRESET" ;DO REAL RESET
982 MOVE A,(AB) ;RETURN ARG
986 ; HERE ON BAD INPUT CHARACTER
988 BADCHR: PUSH TP,$TATOM
989 PUSH TP,MQUOTE BAD CHARACTER IGNORED
996 NEOF: PUSH TP,$TATOM ;GENERATE ERROR MESSAGE
997 PUSH TP,MQUOTE EOF-REACHED
1000 ;LOSING CHANNEL FOR INPUT
1002 CHNLOS: PUSH TP,$TATOM
1003 PUSH TP,MQUOTE BAD-CHANNEL
1009 OPNERR: PUSH TP,$TATOM ;SETUP MESSAGE
1010 PUSH TP,MQUOTE OPEN-FAILED
1013 ;HERE FOR DIRECTION ERROR
1015 WRNGDI: PUSH TP,$TATOM ;SET UP ERROR
1016 PUSH TP,MQUOTE NOT-OPEN-FOR-READING
1021 WRONGT: PUSH TP,$TATOM
1022 PUSH TP,MQUOTE WRONG-TYPE
1025 ;FLOATING POINT NUMBER TOO LARGE OR SMALL
1026 FOOR: PUSH TP,$TATOM
1027 PUSH TP,MQUOTE NUMBER-OUT-OF-RANGE
1034 MOVE B,5(TB) ;GET CHANNEL
1041 ;TABLE OF NAMES OF ARGS AND ALLOWED TYPES
1044 IRP A,,[[[CAIN C,TUNBOU],EOF],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]]
1052 CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST