MUDDLE/nread.14

   1
   2 TITLE READER FOR MUDDLE
   3
   4 ;C. REEVE DEC. 1970
   5
   6 RELOCA
   7
   8 READER==1       ;TELL MUDDLE > TO USE SOME SPECIAL HACKS
   9 FRMSIN==1       ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST
  10
  11 .INSRT MUDDLE >
  12
  13 .GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,TENTAB,CHMAK,FLUSCH,ITENTB
  14 .GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR
  15 .GLOBAL CHRWRD
  16 .GLOBAL NONSPC
  17
  18
  19 ;MACRO TO FLOAT
  20 FF=0    ;FALG REGISTER DURING NUMBER CONVERSION
  21
  22 ;FLAGS USED (RIGHT HALF)
  23
  24 NOTNUM==1       ;NOT A NUMBER
  25 NFIRST==2       ;NOT FIRST CHARACTER BEING READ
  26 DECFRC==4       ;FORCE DECIMAL CONVERSION
  27 NEGF==10        ;NEGATE THIS THING
  28 NUMWIN==20      ;DIGIT(S) SEEN
  29 INSTRN==40      ;IN QUOTED CHARACTER STRING
  30 FLONUM==100     ;NUMBER IS FLOOATING POINT
  31 DOTSEN==200     ;. SEEN IN IMPUT STREAM
  32 EFLG==400       ;E SEEN FOR EXPONENT
  33 IFN FRMSIN,[
  34         FRSDOT==1000                    ;. CAME FIRST
  35         USEAGN==2000                    ;SPECIAL DOT HACK
  36 ]
  37
  38 ;TEMPORARY OFFSETS
  39
  40 VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR
  41 ONUM==1 ;CURRENT NUMBER IN OCTAL
  42 DNUM==3 ;CURRENT NUMBER IN DECIMAL
  43 FNUM==5 ;CURRENTLY UNUSED
  44 CNUM==7 ;IN CURRENT RADIX
  45 NDIGS==11       ;NUMBER OF DIGITS
  46 ENUM==13 ;EXPONENT
  47
  48
  49 \f; TEXT FILE LOADING PROGRAM
  50
  51 MFUNCTION LOAD,SUBR
  52
  53         ENTRY
  54
  55         HLRZ    A,AB            ;GET NO. OF ARGS
  56         CAIE    A,-4            ;IS IT 2
  57         JRST    TRY2            ;NO, TRY ANOTHER
  58         HLRZ    A,2(AB)         ;GET TYPE
  59         CAIE    A,TOBLS         ;IS IT OBLIST
  60         JRST    WRONGT
  61         JRST    CHECK1
  62
  63 TRY2:   CAIE    A,-2            ;IS ONE SUPPLIED
  64         JRST    WNA"
  65
  66 CHECK1: HLRZ    A,(AB)          ;GET TYPE
  67         CAIE    A,TCHAN         ;IS IT A CHANNEL
  68         JRST    WRONGT
  69
  70 LOAD1:  HLRZ    A,TB            ;GET CURRENT TIME
  71         PUSH    TP,$TTIME       ;AND SAVE IT
  72         PUSH    TP,A
  73
  74 LOAD2:  PUSH    TP,(TB)         ;USE TIME AS EOF ARG
  75         PUSH    TP,1(TB)
  76         PUSH    TP,(AB)         ;USE SUPPLIED CHANNEL
  77         PUSH    TP,1(AB)
  78
  79         CAML    AB,[-2,,0]      ;CHECK FOR 2ND ARG
  80         JRST    LOAD3           ;NONE
  81
  82         PUSH    TP,2(AB)        ;PUSH ON 2ND ARG
  83         PUSH    TP,3(AB)
  84         MCALL   3,READ
  85         JRST    CHKRET          ;CHECK FOR EOF RET
  86
  87 LOAD3:  MCALL   2,READ
  88 CHKRET: CAMN    A,(TB)          ;IS TYPE EOF HACK
  89         CAME    B,1(TB)         ;AND IS VALUE
  90         JRST    EVALIT          ;NO, GO EVAL RESULT
  91         PUSH    TP,(AB)
  92         PUSH    TP,1(AB)
  93         MCALL   1,FCLOSE
  94         MOVE    A,$TCHSTR
  95         MOVE    B,CHQUOTE DONE
  96         JRST    FINIS
  97
  98 EVALIT: PUSH    TP,A
  99         PUSH    TP,B
 100         MCALL   1,EVAL
 101         JRST    LOAD2
 102
 103
 104
 105 ; OTHER FILE LOADING PROGRAM
 106
 107
 108 \fMFUNCTION FLOAD,SUBR
 109
 110         ENTRY
 111
 112         MOVEI   C,1             ;INITIALIZE OPEN'S ARG COUNT
 113         PUSH    TP,$TAB ;SLOT FOR SAVED AB
 114         PUSH    TP,[0]  ;EMPTY FOR NOW
 115         PUSH    TP,$TCHSTR      ;PUT IN FIRST ARG
 116         PUSH    TP,CHQUOTE READ
 117         MOVE    A,AB            ;COPY OF ARGUMENT POINTER
 118
 119 FARGS:  JUMPGE  A,CALOPN        ;DONE? IF SO CALL OPEN
 120         HLRZ    B,(A)           ;NO, CH\0ECK TYPE OF THIS ARG
 121         CAIN    B,TOBLS         ;OBLIST?
 122         JRST    OBLSV           ;YES, GO SAVE IT
 123
 124         PUSH    TP,(A)          ;SAVE THESE ARGS
 125         PUSH    TP,1(A)
 126         ADD     A,[2,,2]        ;BUMP A
 127         AOJA    C,FARGS         ;COUNT AND GO
 128
 129 OBLSV:  MOVEM   A,1(TB) ;SAVE THE AB
 130
 131 CALOPN: ACALL   C,FOPEN         ;OPEN THE FILE
 132
 133         JUMPE   B,FNFFL ;FILE MUST NO EXIST
 134         EXCH    A,(TB)  ;PLACE CHANNEL ON STACK
 135         EXCH    B,1(TB)         ;OBTAINING POSSIBLE OBLIST
 136         JUMPN   B,2ARGS         ;OBLIST SUOPPLIED?
 137
 138         MCALL   1,LOAD          ;NO, JUST CALL
 139         JRST    FINIS
 140
 141
 142 2ARGS:  PUSH    TP,(B)          ;PUSH THE OBLIST
 143         PUSH    TP,1(B)
 144         MCALL   2,LOAD
 145         JRST    FINIS
 146
 147
 148 FNFFL:  PUSH    TP,$TATOM
 149         PUSH    TP,MQUOTE FILE-NOT-FOUND
 150         JRST    CALER1
 151
 152 \fMFUNCTION RREADC,SUBR,READCHR
 153
 154         ENTRY
 155         PUSH    P,[IREADC]      ;WHERE TO GO AFTER BINDING
 156         JRST    READ0           ;GO BIND VARIABLES
 157
 158 MFUNCTION NXTRDC,SUBR,NEXTCHR
 159
 160         ENTRY
 161
 162         PUSH    P,[INXTRD]
 163         JRST    READ0
 164
 165 MFUNCTION READ,SUBR
 166
 167         ENTRY
 168
 169         PUSH    P,[IREAD1]      ;WHERE TO GO AFTER BINDING
 170 READ0:  PUSH    TP,$TTP         ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE)
 171         PUSH    TP,[0]
 172         PUSH    TP,$TFIX        ;SLOT FOR RADIX
 173         PUSH    TP,[0]
 174         PUSH    TP,$TCHAN       ;AND SLOT FOR CHANNEL
 175         PUSH    TP,[0]
 176         JUMPGE  AB,READ1        ;NO ARGS, NO BINDING
 177         MOVE    B,AB            ;GET A COPY OF THE ARG BLOCK
 178         MOVEI   D,0             ;ACCESS ARG TABLE
 179 ARGLP:  HLRZ    C,(B)           ;ISOLATE TYPE
 180         XCT     ARGS(D)         ;DO THE APROPRIATE COMPARE
 181         JRST    WRONGT
 182         PUSH    TP,[TATOM,,-1]  ;PUSH THE ATOMS
 183         PUSH    TP,@ARGS+1(D)
 184         PUSH    TP,(B)          ;PUSH ARGS
 185         PUSH    TP,1(B)
 186         PUSH    TP,[0]          ;DUMMY
 187         PUSH    TP,[0]
 188         ADDI    D,2             ;BUMP ARG TBL POINTER
 189         ADD     B,[2,,2]        ;AND ARG POINTER
 190         JUMPL   B,ARGLP         ;MORE?
 191
 192         PUSHJ   P,SPECBIND      ;NO, GO BIND
 193
 194
 195 \f; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS
 196
 197 READ1:  MOVE    B,MQUOTE INCHAN,,       ;GET INPUT CHANNEL
 198         MOVSI   A,TATOM
 199         PUSHJ   P,IDVAL         ;NOW GOBBLE THE REAL CHANNEL
 200         CAME    A,$TCHAN        ;IS IT A CHANNEL
 201         JRST    CHNLOS
 202         MOVEM   B,5(TB)         ;SAVE CHANNEL
 203         MOVEI   B,DIRECT-1(B)   ;POINT TO DIRECTION
 204         PUSHJ   P,CHRWRD        ;GOBBLE AND CHECK
 205         JRST    WRNGDI
 206         CAME    B,[ASCIZ /READ/]
 207         JRST    WRNGDI
 208         MOVE    B,5(TB)
 209 GETIO:  MOVE    A,IOINS(B)      ;GOBBLE THE I/O INSTRUCTION
 210         JUMPE   A,OPNFIL        ;GO REALLY OPEN THE CROCK
 211         MOVE    A,RADX(B)       ;GET RADIX
 212         MOVEM   A,3(TB)
 213         MOVEM   B,5(TB) ;SAVE CHANNEL
 214 REREAD: MOVE    D,LSTCH(B)      ;ANY CHARS AROUND?
 215         CAIN    D,233           ;FLUSH THE TERMINATOR HACK
 216         SETZM   LSTCH(B)
 217
 218         PUSHJ   P,@(P)          ;CALL INTERNAL READER
 219         JRST    BADTRM          ;LOST
 220 RFINIS: MOVE    C,5(TB)         ;GET CHANNEL
 221         MOVE    D,LSTCH(C)              ;GET LAST CHR
 222         CAIN    D,233           ;SPECIAL ENDER?
 223         SETZM   LSTCH(C)                ;YES CLOBBER
 224         SUB     P,[1,,1]        ;POP OFF LOSER
 225         JRST    FINIS
 226
 227 BADTRM: CAIE    B,3             ;READ 'FAILED' IS LOSER EOF
 228         JRST    CHLSTC          ;NO, MUST BE UNMATCHED PARENS
 229         PUSH    TP,4(TB)                ;CLOSE THE CHANNEL
 230         PUSH    TP,5(TB)
 231         MCALL   1,FCLOSE
 232         MOVE    B,MQUOTE EOF,,  ;GET EOF
 233         MOVSI   A,TATOM
 234         PUSHJ   P,IDVAL         ;GET LOCAL VALUE
 235         CAMN    A,$TUNBOU       ;UNBOUND IS ONLY LOSER
 236         JRST    NEOF
 237         PUSH    TP,A            ;SETUP CALL TO EVAL
 238         PUSH    TP,B
 239         MCALL   1,EVAL          ;AND EVAL IT
 240         JRST    RFINIS          ; AND RETURN
 241
 242 ;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL
 243
 244 OPNFIL: PUSHJ   P,OPNCHN        ;GO DO THE OPEN
 245         JUMPE   B,OPNERR        ;LOSE IC B IS 0
 246         JRST    GETIO
 247
 248
 249 CHLSTC: MOVE    B,5(TB)         ;GET CHANNEL BACK
 250         JRST    REREAD
 251
 252 \f;MAIN ENTRY TO READER
 253
 254 IREAD:
 255         PUSHJ   P,LSTCHR        ;DON'T REREAD LAST CHARACTER
 256 IREAD1: INTGO
 257         PUSH    TP,(TB)         ;SAVE LAST FORM
 258         PUSH    TP,1(TB)
 259 BDLP:   PUSHJ   P,NXTCH         ;GOBBLE CHAR IN A AND TYPE IN D
 260         CAIG    B,ENTYPE
 261         JUMPN   B,@.+1(B)       ;ERROR ON ZERO TYPE OR FUNNY TYPE
 262         JRST    BADCHR
 263 DTBL:   NUMLET                  ;HERE IF NUMBER OR LETTER
 264         NUMLET                  ;NUMBER
 265 NUMCOD==.-DTBL
 266         NUMLET                  ;+-
 267         NUMLET                  ;.
 268 DOTTYP==.-DTBL
 269         NUMLET                  ;E
 270         QUOTIT                  ;' - QUOTE THE FOLLOWING GOODIE
 271 QUOTYP==.-DTBL
 272
 273         MACCAL                  ;% - INVOKE A READ TIME MACRO
 274 MACTYP==.-DTBL
 275         NUMLET                  ;\ - ESCAPE,BEGIN ATOM
 276
 277 ESCTYP==.-DTBL  ;TYPE OF ESCAPE CHARACTER
 278         QMARK                   ;? - SEVERAL POSSIBILITIES
 279 QMTYP==.-DTBL
 280         ALTACT                  ;_ - <ALTER ...>
 281 ARRTYP==.-DTBL
 282         GLOVAL                  ;, - GET GLOBAL VALUE
 283 GLMNT==.-DTBL
 284
 285 NONSPC==.-DTBL  ;NUMBER OF NON-SPECIAL CHARACTERS
 286         SPACE                   ;SPACING CHAR CR,LF,SP,TAB ETC.
 287 SPATYP==.-DTBL  ;TYPE FOR SPACE CHARS
 288
 289
 290 ;THE FOLLOWING ENTRIES ARE VARIOUS PUNCTUATION CROCKS
 291
 292         LPAREN                  ;( - BEGIN LIST
 293 LPRTYP==.-DTBL
 294         RPAREN                  ;) - END CURRENT LEVEL OF INPUT
 295         LBRACK                  ;[ -BEGIN ARRAY
 296 LBRTYP==.-DTBL
 297         RBRACK                  ;] - END OF ARRAY
 298         CSTRING                 ;" - CHARACTER STRING
 299 CSTYP==.-DTBL
 300
 301         SPECTY                  ;# - SPECIAL TYPE TO BE READ
 302         OPNANG                  ;< - BEGIN ELEMENT CALL
 303
 304 SLMNT==.-DTBL   ;TYPE OF START OF SEGMENT
 305
 306         CLSANG                  ;> - END ELEMENT CALL
 307
 308
 309         EOFCHR                  ;^C - END OF FILE
 310
 311         COMNT                   ;; - BEGIN COMMENT
 312
 313 NTYPES==.-DTBL
 314 \f
 315
 316
 317 ; EXTENDED TABLE FOR ! HACKS
 318
 319         SEGDOT                  ;!. - CALL TO LVAL (SEG)
 320 DOTEXT==.-DTBL
 321         UVECIN                  ;![ - INPUT UNIFORM VECTOR ]
 322 LBREXT==.-DTBL
 323         QUOSEG                  ;!' - SEG CALL TO QUOTE
 324 QUOEXT==.-DTBL
 325         SINCHR                  ;!" - INPUT ONE CHARACTER
 326 CSEXT==.-DTBL
 327         SEGIN                   ;!< - SEG CALL
 328 SLMEXT==.-DTBL
 329         GLOSEG                  ;!, - SEG CALL TO GVAL
 330 GLMEXT==.-DTBL
 331         TERM                    ;!$ - (EXCAL-ALT MODE) PUT ALL CLOSES
 332 MANYT==.-DTBL
 333         GIVSEG                  ;!<GIVEN...>
 334 QMEXT==.-DTBL
 335         ALTSEG                  ;!_ - !@<ALTER...>
 336 BAREXT==.-DTBL
 337 ENTYPE==.-DTBL
 338
 339
 340 ;TRANSLATION TABLE FOR EXTENDED THINGIES
 341
 342 EXTTBL: NUMCOD-1                ;!LETTER = LETTER
 343         NUMCOD                  ;!NUM = NUM
 344         NUMCOD+1                ;!+- = +-
 345         DOTEXT                  ;!. = !<LVAL....>, PROBABLY
 346         DOTTYP+1                ;!E = E
 347         QUOEXT                  ;!' = !<QUOTE...>
 348         MACTYP                  ;!% = %
 349         ESCTYP                  ;!\ = \
 350         QMEXT                   ;!? = !<GIVEN...>
 351         BAREXT                  ;!_ = !<ALTER...>
 352         GLMEXT                  ;!, = !<GVAL...>
 353         SPATYP                  ;!SPACE = SPACE
 354         LPRTYP                  ;!( = (
 355         LBRTYP-1                ;!) = )
 356         LBREXT                  ;![ = #UVECTOR[...]
 357         LBRTYP+1                ;!] = ]
 358         CSEXT                   ;!" = ONE CHAR NEXT
 359         CSTYP+1                 ;!# = #
 360         SLMEXT                  ;!< = #SEGMENT(...)
 361         SLMNT+1                 ;!> = >
 362         SLMNT+2                 ;!^C = ^C
 363         SLMNT+3                 ;!; = ;
 364
 365 SPACE:  PUSHJ   P,LSTCHR                ;DON'T REREAD SPACE
 366         JRST    BDLP\f
 367 ;HERE ON NUMBER OR LETTER, START ATOM
 368
 369 NUMLET: PUSHJ   P,GOBBLE        ;READ IN THE ATOM AND PUT PNTR ON ARG PDL
 370         JRST    RET             ;NO SKIP RETURN I.E. NON NIL
 371
 372 ;HERE TO START BUILDING A CHARACTER STRING GOODIE
 373
 374 CSTRING:        PUSHJ   P,GOBBL1        ;READ IN STRING
 375         JRST    RET
 376
 377 ;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION
 378
 379 MACCAL: PUSHJ   P,NXTCH1        ;READ ONE MORE CHARACTER
 380         CAIE    B,MACTYP        ;IS IT ANOTHER MACRO CHAR
 381
 382         JRST    MACAL1          ;NO, CALL MACRO AND USE VALUE
 383         PUSHJ   P,LSTCHR        ;DONT REREAD %
 384         PUSHJ   P,MACAL1        ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE
 385         JFCL                    ;IGNORE LOSER
 386         JRST    IREAD1
 387
 388 MACAL1: PUSHJ   P,IREAD1        ;READ FUNCTION NAME
 389         PUSHJ   P,ERRPAR        ;BAD PARENS
 390         PUSH    TP,A            ;SAVE THE RESULT
 391         PUSH    TP,B            ;AND USE IT AS AN ARGUMENT
 392         MCALL   1,EVAL
 393         JRST    RET
 394
 395 ;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT
 396
 397 SPECTY: PUSHJ   P,IREAD         ;READ THE TYPES NAME (SHOULD BE AN ATOM)
 398         PUSHJ   P,ERRPAR
 399         PUSH    TP,A            ;BEGIN SETTING UP CHTYPE CALL
 400         PUSH    TP,B
 401         PUSHJ   P,IREAD1        ;NOW READ STRUCTURE
 402         PUSHJ   P,ERRPAR        ;LOSSAGE
 403         EXCH    A,-1(TP)        ;USE AS FIRST ARG
 404         EXCH    B,(TP)
 405         PUSH    TP,A            ;USE OTHER AS 2D ARG
 406         PUSH    TP,B
 407         MCALL   2,CHTYPE        ;ATTEMPT TO MUNG
 408         JRST    RET
 409 \f
 410 ;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS
 411 ;BETWEEN (),  ARRIVED AT WHEN ( IS READ
 412
 413 SEGIN:  PUSH    TP,$TSEG
 414         JRST    OPNAN1
 415
 416 OPNANG: PUSH    TP,$TFORM       ;SAVE TYPE
 417 OPNAN1: PUSH    P,[">]
 418         JRST    LPARN1
 419
 420 LPAREN: PUSH    P,[")]
 421         PUSH    TP,$TLIST       ;START BY ASSUMING NIL
 422 LPARN1: PUSH    TP,[0]
 423         PUSHJ   P,LSTCHR        ;DON'T REREAD PARENS
 424 LLPLOP: PUSHJ   P,IREAD1        ;READ IT
 425         JRST    LDONE           ;HIT TERMINATOR
 426
 427 ;HERE WHEN MUST ADD CAR TO CURRENT WINNER
 428
 429 GENCAR: PUSH    TP,A            ;SAVE TYPE OF VALUE
 430         PUSH    TP,B            ;AND VALUE
 431         MCALL   1,NCONS         ;GOBBLE NIL LISTE
 432         MOVEM   A,(TB)          ;SAVE AWAY
 433         MOVEM   B,1(TB)         ;FOR COMMENT
 434         POP     TP,C            ;GET CDR
 435         JUMPN   C,CDRIN         ;IF STACKED GOODIE NOT NIL SKIP
 436         MOVE    C,(TP)          ;FIX UP LAT TYPE
 437         MOVEM   C,(TB)
 438         PUSH    TP,B            ;AND USE AS TOTAL VALUE
 439         PUSH    TP,A            ;SAVE THIS AS FIRSST THING ON LIST
 440         JRST    .+2             ;SKIP CDR SETTING
 441 CDRIN:  HRRM    B,(C)
 442         PUSH    TP,B            ;CLOBBER IN NEW PARTIAL GOODIE
 443         JRST    LLPLOP          ;AND CONTINUE
 444
 445 ; HERE TO RAP UP LIST
 446
 447 LDONE:  CAME    B,(P)           ;CHECK VALIDITY OF CHARACTER
 448         PUSHJ   P,MISMAT        ;REPORT MISMATCH
 449         SUB     P, [1,,1]
 450         POP     TP,B            ;GET VALUE OF PARTIAL RESULT
 451         POP     TP,A            ;AND TYPE OF SAME
 452         JUMPE   B,RET           ;VALUE IS NIL, DON'T POP AGAIN
 453         POP     TP,B            ;POP FIRST LIST ELEMENT
 454         POP     TP,A            ;AND TYPE
 455         JRST    RET
 456 \f
 457 ;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS
 458 UVECIN: PUSH    P,[EUVECTOR]    ;PUSH NAME OF U VECT HACKER
 459         JRST    LBRAK2          ;AND GO
 460
 461 LBRACK: PUSH    P,[EVECTOR]             ;PUSH GEN VECTOR HACKER
 462 LBRAK2: PUSHJ   P,LSTCHR        ;FORCE READING NEW CHAR
 463         PUSH    P,[0]           ;INITIALIZE TO (WILL COUNT VECTOR ELEMENTS)
 464
 465 LBRAK1: PUSHJ   P,IREAD1        ;RECURSIVELY READ  ELEMENTS OF ARRAY
 466         JRST    LBDONE          ;RAP UP ON TERMINATOR
 467
 468 STAKIT: PUSH    TP,A            ;SAVE RESULT TYPE
 469         PUSH    TP,B            ;AND VALUE
 470         AOS     VCNT(P)         ;AND COUNT
 471         JRST    LBRAK1
 472
 473 ; HERE TO RAP UP VECTOR
 474
 475 LBDONE: CAIE    B,"]            ;FINISHED RETURN (WAS THE RIGHT STOP USED?)
 476         PUSHJ   P,MISMAB        ;WARN USER
 477         MOVE    A,VCNT(P)
 478         ACALL   A,@-1(P)        ;MAKE THE VECTOR
 479         SUB     P,[2,,2]
 480         JRST    RET
 481
 482
 483 ; BUILD A SINGLE CHARACTER ITEM
 484
 485 SINCHR: PUSHJ   P,NXTC1         ;FORCE READ NEXT
 486         CAIN    B,ESCTYP                ;ESCAPE?
 487         PUSHJ   P,NXTC1         ;RETRY
 488         LSHC    A,29.-36.       ;POSITION IN B
 489         MOVSI   A,TCHRS
 490         JRST    RETCL
 491
 492 \f
 493 ; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C
 494
 495 CLSANG:                         ;CLOSE ANGLE BRACKETS
 496 RBRACK:                         ;COMMON RETURN FOR END OF ARRAY ALSO
 497 RPAREN: PUSHJ   P,LSTCHR        ;DON'T REREAD
 498 EOFCHR: MOVE    B,A             ;GETCHAR IN B
 499         MOVSI   A,TCHRS         ;AND TYPE IN A
 500         JRST    RET1            ;AND LEAVE
 501
 502 ; NORMAL RETURN FROM IREAD/IREAD1
 503
 504 RETCL:  PUSHJ   P,LSTCHR        ;DONT REREAD
 505 RET:    AOS     (P)             ;SKIP
 506 RET1:   POP     TP,1(TB)        ;SAVE LAST READ CROCK
 507         POP     TP,(TB)
 508         POPJ    P,
 509
 510
 511 ;RANDOM MINI-SUBROUTINES USED BY THE READER
 512
 513 ;READ A CHAR INTO A AND TYPE CODE INTO D
 514
 515 NXTC1:  MOVE    B,5(TB) ;GET CHANNEL
 516         JRST    NXTC2
 517 NXTC:   MOVE    B,5(TB) ;GET CHANNEL
 518         SKIPN   A,LSTCH(B)      ;CHAR IN A IF REUSE
 519 NXTC2:  XCT     IOINS(B)        ;GET CHARACTER FROM INPUT
 520         ANDI    A,377           ;INCASE IT IS EOF
 521         MOVEM   A,LSTCH(B)      ;SAVE THE CHARACTER
 522         TRZE    A,200           ;DONT SKIP IF SPECIAL
 523         JRST    RETYPE          ;GO HACK SPECIALLY
 524 GETCTP: PUSH    P,A     ;AND SAVE FROM DIVISION
 525         IDIVI   A,CHRWD ;YIELDS WORD AND CHAR NUMBER
 526         LDB     B,BYTPNT(B)     ;GOBBLE TYPE CODE
 527         POP     P,A
 528         POPJ    P,
 529
 530 ; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK !
 531 ; HACKS
 532
 533 NXTCH1: PUSHJ   P,NXTC1         ;READ CHAR
 534         JRST    .+2
 535 NXTCH:  PUSHJ   P,NXTC          ;READ CHAR
 536         CAIE    B,NTYPES+1      ;IF 1 > THAN MAX, MUST BE SPECIAL
 537         POPJ    P,              ;OTHERWISE JUST RETURN
 538
 539         PUSHJ   P,NXTC1         ;READ NEXT ONE
 540         CAIN    B,1             ;LETTER?
 541         JRST    UPLO            ;YES, INVERT CASE
 542 RETYP1: CAIN    B,SPATYP                ;SPACER?
 543         JRST    CHKALT          ;YES, CHECK IT
 544         MOVE    B,EXTTBL-1(B)   ;USE TABLE FOR ALL OTHERS
 545
 546 CRMLST: ADDI    A,200           ;CLOBBER LASTCHR
 547         PUSH    P,B
 548         MOVE    B,5(TB)         ;POINT TO CHANNEL
 549         MOVEM   A,LSTCH(B)
 550         SUBI    A,200           ;DECREASE CHAR
 551         POP     P,B
 552         POPJ    P,
 553
 554 UPLO:   ADDI    A,40            ;CHANGE CASE OF LETTER IN A
 555         CAIL    A,173
 556         SUBI    A,100
 557         JRST    CRMLST
 558
 559 RETYPE: PUSHJ   P,GETCTP        ;GET TYPE OF CHAR
 560         JRST    RETYP1
 561
 562
 563 CHKALT: CAIN    A,33            ;ALT?
 564         MOVEI   B,MANYT
 565         JRST    CRMLST
 566
 567
 568 TERM:   MOVEI   B,0             ;RETURN A 0
 569         POPJ    P,              ;AND RETURN
 570 \f
 571
 572
 573 ;TABLE OF BYTE POINTERS FOR GETTING CHARS
 574
 575 BYTPNT":        350700,,CHTBL(A)
 576         260700,,CHTBL(A)
 577         170700,,CHTBL(A)
 578         100700,,CHTBL(A)
 579         010700,,CHTBL(A)
 580
 581 ;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS
 582 ;IN THE NUMBER LETTER CATAGORY)
 583
 584 SETCHR 2,[0123456789]
 585
 586 SETCHR 3,[+-]
 587
 588 SETCHR 4,[.]
 589
 590 SETCHR 5,[Ee]
 591
 592 INCRCH 6,['%\?_,]               ;NON-ATOM KILLING SPECIALS
 593
 594 SETCOD 14,[15,12,11,14,40,33]   ;ALL ARE TYPE 14 (SPACING - FF,TAB,SPACE,ALT-MODE)
 595
 596 INCRCH 15,[()[]"#<>]    ;GIVE THESE INCREASING CODES FROM 15
 597
 598 SETCOD 25,[3]   ;^C - EOF CHARACTER
 599
 600 INCRCH 26,[;!]          ;COMMENT AND SPECIAL
 601
 602 CHTBL:
 603         OUTTBL                  ;OUTPUT THE TABLE RIGHT HERE
 604
 605
 606 \f
 607 ; THIS CODE ASSOCIATES A COMMENT WITH THE LAST READ GOODIE
 608
 609 COMNT:  HLRZ    A,(TB)          ;CHECK THERE IS AN ITEM TO COMMENT
 610         CAIN    A,TTP           ;TYPE TP MEANS NONE THERE
 611         JRST    NOCMNT
 612         PUSH    TP,(TB)         ;SAVE THEM
 613         PUSH    TP,1(TB)
 614         MOVSI   A,TTP           ;RESET LAST GOODIE
 615         MOVEM   A,(TB)
 616         SETZM   1(TB)
 617         PUSHJ   P,IREAD         ;CALL READER FLUSHING ,
 618         PUSHJ   P,ERRPAR
 619         PUSH    TP,$TATOM
 620         PUSH    TP,MQUOTE COMMENT
 621         PUSH    TP,A            ;PUSH THE COMMENT
 622         PUSH    TP,B
 623         MCALL   3,PUT           ;PUT THE COMMENT ON
 624         JRST    BDLP
 625
 626 ; THIS CODE FLUSHES WANDERING COMMENTS
 627
 628 NOCMNT: PUSHJ   P,IREAD
 629         PUSHJ   P,ERRPAR
 630         JRST    BDLP
 631 \f
 632 ;SUBROUTINE TO READ CHARS ONTO STACK
 633
 634 GOBBL1: MOVEI   FF,0            ;KILL ALL FLAGS
 635         PUSHJ   P,LSTCHR        ;DON'T REREAD "
 636         TROA    FF,NOTNUM+INSTRN        ;SURPRESS NUMBER CONVERSION
 637 GOBBLE: MOVEI   FF,0            ;FLAGS CONCERRNING CURRENT GOODIE IN HERE
 638         MOVE    A,TP            ;GOBBLE CURRENT TP TO BE PUSHED
 639         MOVEI   C,6             ;NOW PUSH 6 0'S ON TO STACK
 640         PUSH    TP,$TFIX        ;TYPE IS FIXED
 641         PUSH    TP,FF           ;AND VALUE IS 0
 642         SOJG    C,.-2           ;FOUR OF THEM
 643         PUSH    TP,$TTP         ;NOW SAVE OLD TP
 644         ADD     A,[1,,1]        ;MAKE IT LOOK LIKE A TB
 645         PUSH    TP,A
 646         MOVEI   D,0             ;ZERO OUT CHARACTER COUNT
 647 GOB1:   MOVEI   C,0             ;SET UP FIRST WORD OF CHARS
 648         PUSH    P,[440700,,C]   ;BYTE POINTER
 649 GOB2:   PUSH    P,FF            ;SAVE FLAG REGISTER
 650         INTGO
 651         PUSHJ   P,NXTCH         ;READ A CHAACTER
 652         POP     P,FF            ;AND RESTORE FLAG REGISTER
 653         CAIN    B,ESCTYP        ;IS IT A CHARACTER TO BE ESCAPED
 654         JRST    ESCHK           ;GOBBLE THE ESCAPED CHARACTER
 655         TRNE    FF,INSTRN       ;ARE WE BUILDING A CHAR STRING
 656         JRST    ADSTRN          ;YES, GO READ IN
 657         CAILE   B,NONSPC        ;IS IT SPECIAL
 658         JRST    DONEG           ;YES, RAP THIS UP
 659
 660         TRNE    FF,NOTNUM       ;IS  NUMERIC STILL WINNING
 661         JRST    SYMB2           ;NO, ONLY DO CHARACTER HACKING
 662         CAIL    A,60            ;CHECK FOR DIGIT
 663         CAILE   A,71
 664         JRST    SYMB1   ;NOT A DIGIT
 665         JRST    CNV             ;GO CONVERT TO NUMBER
 666 \fCNV:
 667
 668 ;ARRIVE HERE IF STILL BUILDING A NUMBER
 669 CNV:    MOVE    B,(TP)  ;GOBBLE POINTER TO TEMPS
 670         TRO     FF,NUMWIN       ;SAY DIGITSSEEN
 671         SUBI    A,60    ;CONVERT TO  A NUMBER
 672         TRNE    FF,EFLG ;HAS E BEEN SEEN
 673         JRST    ECNV            ;YES, CONVERT EXPONENT
 674         TRNE    FF,DOTSEN       ;HAS A DOT BEEN SEEN
 675
 676         JRST    DECNV           ;YES, THIS IS A FLOATING NUMBER
 677
 678         JFCL    17,.+1  ;KILL ALL FLAGS
 679         MOVE    E,CNUM(B)       ;COMPUTE CURRENT RADIX
 680         IMUL    E,3(TB)
 681         ADD     E,A     ;ADD IN CURRENT DIGIT
 682         JFCL    10,.+2
 683         MOVEM   E,CNUM(B)       ;AND SAVE IT
 684
 685
 686
 687 ;INSERT OCTAL AND CRADIX CROCK HERE IF NECESSSARY
 688         JRST    DECNV1          ;CONVERT TO DECIMAL(FIXED)
 689
 690
 691 DECNV:  TRO     FF,FLONUM       ;SET FLOATING FLAG
 692 DECNV1: JFCL    17,.+1  ;CLEAR ALL FLAGS
 693         MOVE    E,DNUM(B)       ;GET DECIMAL NUMBER
 694         IMULI   E,10.
 695         JFCL    10,CNV2 ;JUMP IF OVERFLOW
 696         ADD     E,A     ;ADD IN DIGIT
 697         MOVEM   E,DNUM(B)
 698         TRNE    FF,FLONUM       ;IS THIS FRACTION?
 699         SOS     NDIGS(B)        ;YES, DECREASE EXPONENT BY ONE
 700
 701 CNV1:   PUSHJ   P,NXTCH         ;RE-GOBBLE CHARACTER
 702         JRST    SYMB2           ;ALSO DEPOSIT INTO SYMBOL BEING MADE\rîCNV2:                             ;OVERFLOW IN DECIMAL NUMBER
 703         TRNE    FF,DOTSEN       ;IS THIS FRACTION PART?
 704         JRST    CNV1            ;YES,IGNORE DIGIT
 705         AOS     NDIGS(B)        ;NO, INCREASE IMPLICIT EXPONENT BY ONE
 706         TRO     FF,FLONUM       ;SET FLOATING FLAG BUT
 707         JRST    CNV1            ;DO NOT FORCE DECIMAL(DECFRC)
 708
 709 ECNV:                   ;CONVERT A DECIMAL EXPONENT
 710         HRRZ    E,ENUM(B)       ;GET EXPONENT
 711         IMULI   E,10.
 712         ADD     E,A             ;ADD IN DIGIT
 713         TLNN    E,777777        ;IF OVERFLOW INTO LEFT HALF
 714         HRRM    E,ENUM(B)       ;DO NOT STORE(CATCH ERROR LATER)
 715         JRST    CNV1
 716         JRST    SYMB2           ;ALSO DEPOSIT INTO SYMBOL BEING MADE
 717
 718 \f
 719 ;HERE TO PUT INTO IDENTIFIER BEING BUILT
 720
 721 ESCHK:  PUSHJ   P,NXTC1         ;GOBBLE NEXT CHAR
 722 SYMB:   MOVE    B,(TP)          ;GET BACK TEM POINTER
 723         TRNE    FF,EFLG         ;IF E FLAG SET
 724         HLRZ    FF,ENUM(B)      ;RESTORE SAVED FLAGS
 725         TRO     FF,NOTNUM       ;SET NOT NUMBER FLAG
 726 SYMB2:  TRO     FF,NFIRST       ;NOT FIRST IN WORLD
 727 SYMB3:  IDPB    A,(P)           ;INSERT IT
 728         PUSHJ   P,LSTCHR        ;READ NEW CHARACTER
 729         TRNN    C,377           ;WORD FULL?
 730         JRST    GOB2            ;NO, KEEP TRYING
 731         MOVEM   C,(P)           ;YES,STORE IT
 732         AOJA    D,GOB1          ;COUNT WORD AND GO
 733
 734 ;HERE TO CHECK FOR +,-,. IN NUMBER
 735
 736 SYMB1:  TRNE    FF,NFIRST       ;IS THIS THE FIRST CHARACTER
 737         JRST    CHECK.          ;NO, ONLY LOOK AT DOT
 738         CAIE    A,"-            ;IS IT MINUS
 739         JRST    .+3             ;NO CHECK PLUS
 740         TRO     FF,NEGF         ;YES, NEGATE AT THE END
 741         JRST    SYMB2
 742         CAIN    A,"+            ;IS IT +
 743         JRST    SYMB2           ;ESSENTIALLY IGNORE IT
 744
 745 ;COULD BE .
 746
 747 CHECK.: PUSHJ   P,LSTCHR        ;FLUSH LAST CHARACTER
 748         MOVEI   E,0
 749         TRNN    FF,DOTSEN+EFLG  ;IF ONE ALREADY SEEN
 750         CAIE    A,".
 751         JRST    CHECKE          ;GO LOOK FOR E
 752
 753 IFN FRMSIN,[
 754         TRNN    FF,NFIRST       ;IS IT THE FIRST
 755         JRST    DOT1            ;YES, COULD MEAN EVALUATE A VARIABLE
 756 ]
 757
 758 CHCK.1: TRO     FF,DECFRC+DOTSEN        ;FORCE DECIMAL
 759 IFN FRMSIN,     TRNN    FF,FRSDOT       ;IF NOT FIRST ., PUT IN CHAR STRING
 760         JRST    SYMB2           ;ENTER INTO SYMBOL
 761 IFN FRMSIN,     JRST    GOB2            ;IGNORE THE "."
 762 \f
 763
 764
 765 IFN FRMSIN,[
 766
 767 ;HERE TO SET UP FOR .FOO ..FOO OR.<ABC>
 768
 769 DOT1:   PUSH    P,FF            ;SAVE FLAGS
 770         PUSHJ   P,NXTCH1        ;GOBBLE A NEW CHARACTER
 771         POP     P,FF            ;RESTORE FLAGS
 772         TRO     FF,FRSDOT               ;SET FLAG IN CASE
 773         CAIN    B,NUMCOD                ;SKIP IF NOT NUMERIC
 774         JRST    CHCK.1          ;NUMERIC, COULD BE FLONUM
 775
 776 ; CODE TO HANDLE ALL IMPLICIT CALLS  I.E. QUOTE, LVAL, GVAL
 777
 778         MOVSI   B,TFORM         ;LVAL
 779         MOVE    A,MQUOTE LVAL
 780         SUB     P,[2,,2]        ;POP OFF BYTE POINTER AND GOBBLE CALL
 781         POP     TP,TP
 782         SUB     TP,[1,,1]       ;REMOVE  TP JUNK
 783         JRST    IMPCA1
 784
 785 GLOSEG: SKIPA   B,$TSEG         ;SEG CALL TO GVAL
 786 GLOVAL: MOVSI   B,TFORM ;FORM CALL TO SAME
 787         MOVE    A,MQUOTE GVAL
 788         JRST    IMPCAL
 789
 790 QUOSEG: SKIPA   B,$TSEG         ;SEG CALL TO QUOTE
 791 QUOTIT: MOVSI   B,TFORM
 792         MOVE    A,MQUOTE QUOTE
 793         JRST    IMPCAL
 794
 795 GIVSEG: MOVSI   B,TSEG          ;#SEGMENT
 796         MOVE    A,MQUOTE GIVEN
 797         JRST    IMPCAL          ;(GIVEN...)
 798
 799 GIVACT: MOVSI   B,TFORM         ;#FORM
 800         MOVE    A,MQUOTE GIVEN
 801         JRST    IMPCA1          ;(GIVEN...)
 802
 803 ALTSEG: SKIPA   B,$TSEG         ;#SEGMENT
 804 ALTACT: MOVSI   B,TFORM         ;#FORM
 805         MOVE    A,MQUOTE ALTER
 806         JRST    IMPCAL          ;(ALTER...)
 807
 808 SEGDOT: MOVSI   B,TSEG          ;SEG CALL TO LVAL
 809         MOVE    A,MQUOTE LVAL
 810 IMPCAL: PUSHJ   P,LSTCHR        ;FLUSH LAST CHAR EXCEPT
 811 IMPCA1: PUSH    TP,$TATOM       ;FOR .FOO FLAVOR
 812         PUSH    TP,A            ;PUSH ARGS
 813         PUSH    P,B             ;SAVE TYPE
 814         PUSHJ   P,IREAD1                ;READ
 815         PUSHJ   P,ERRPAR
 816 IMPCA2: PUSH    TP,A            ;PUSH RESULTS
 817         PUSH    TP,B
 818         MCALL   2,LIST          ;MAKE THE LIST
 819         POP     P,A             ;GET FINAL TYPE
 820         JRST    RET             ;AND RETURN
 821
 822
 823
 824 ;? CAN MEAN ? OR <GIVEN X> OR #UNASSIGNED(...)
 825
 826 QMARK:  PUSHJ   P,LSTCHR                ;FLUSH "?"
 827         PUSHJ   P,NXTCH         ;GET NEXT CHARACTER
 828         CAIN    B,LPRTYP                ;"?("?
 829         JRST    UNASIN          ;YES- TYPE UNASSIGNED
 830         CAILE   B,NONSPC                ;NEXT CHARACTER BREAKS ATOMS?
 831         JRST    ANY             ;YES- HAVE STAND-ALONE "?"
 832         JRST    GIVACT          ;NO- NEXT THING IS ATOM
 833 UNASIN: PUSHJ   P,IREAD1                ;READ NEXT THING
 834         PUSHJ   P,ERRPAR
 835         PUSH    TP,A
 836         PUSH    TP,B
 837         PUSH    TP,$TATOM
 838         PUSH    TP,MQUOTE UNASSIGNED
 839         MCALL   2,CHTYPE                ;CHANGE ITS TYPE TO UNASSIGNED
 840         JRST    RET
 841 ANY:    PUSH    P,[ASCIZ /?/]   ;? ALONE MUST BE ATOM
 842         PUSH    P,[1]           ;WITH ONE WORD PNAME
 843         MOVSI   A,TATOM
 844         MOVE    B,MQUOTE        OBLIST,
 845         PUSHJ   P,IDVAL         ;PUT ON CURRENT OBLIST
 846         PUSHJ   P,RLOOKU
 847         JRST    RET
 848 \f
 849 ;HERE AFTER READING ATOM TO CALL VALUE
 850
 851 .SET:   SUB     P,[1,,1]        ;FLUSH GOBBLE CALL
 852         PUSH    P,$TFORM        ;GET WINNING TYPE
 853 .SET1:  PUSH    TP,$TATOM
 854         PUSH    TP,MQUOTE LVAL
 855         JRST    IMPCA2          ;GO CONS LIST
 856
 857 ]
 858
 859 ;HERE TO CHECK FOR "E" FLAVOR OF EXPONENT
 860
 861 CHECKE: TRNN    FF,EFLG         ;HAS ONE BEEN SEEN
 862         CAIE    A,"E            ;IF NOT, IS THIS ONE
 863         JRST    SYMB            ;NO, ENTER AS SYMBOL KILL NUMERIC WIN
 864
 865         TRNN    FF,NUMWIN       ;HAVE DIGITS BEEN SEEN?
 866         JRST    SYMB            ;NO, NOT A NUMBER
 867         MOVE    B,(TP)          ;GET POINTER TO TEMPS
 868         HRLM    FF,ENUM(B)      ;SAVE FLAGS
 869         HRRI    FF,DECFRC+DOTSEN+EFLG   ;SET NEW FLAGS
 870         JRST    SYMB3           ;ENTER SYMBOL
 871
 872
 873 ;HERE ON READING CHARACTER STRING
 874
 875 ADSTRN: CAIN    B,MANYT         ;TERMINATE?
 876         JRST    DONEG           ;YES
 877         CAIE    A,""            ;QUOTE CHAR?
 878         JRST    SYMB2           ;NO JUST INSERT IT
 879 ADSTN1: PUSHJ   P,LSTCHR        ;DON'T REREAD """
 880
 881 \f
 882 ;HERE TO FINISH THIS CROCK
 883
 884 DONEG:  TRNN    FF,NUMWIN       ;HAVE DIGITS BEEN SEEN?
 885         TRO     FF,NOTNUM       ;NO,SET NOT NUMBER FLAG
 886         POP     P,A             ;FLUSH POINT BYTER
 887         JUMPE   C,.+3           ;LAST WORD USED?
 888         PUSH    P,C             ;YES, STORE IT
 889         AOS     D               ;AND BUMP COUNT
 890         PUSH    P,D             ;SAVE IT
 891         TRNN    FF,NOTNUM       ;NUMERIC?
 892         JRST    NUMHAK          ;IS NUMERIC, GO TO IT
 893
 894 IFN FRMSIN,[
 895         MOVE    A,(TP)          ;GET POINTER TO TEMPS
 896         MOVEM   FF,NDIGS(A)     ;USE TO HOLD FLAGS
 897 ]
 898         TRNE    FF,INSTRN       ;ARE WE BUILDING A STRING
 899         JRST    MAKSTR          ;YES, GO COMPLETE SAME
 900         MOVSI   A,TATOM         ;GET AATOM TYPE
 901         MOVE    B,MQUOTE OBLIST,
 902         PUSHJ   P,IDVAL         ;GET VALUE
 903         PUSHJ   P,RLOOKU
 904
 905 IFN FRMSIN,[
 906         MOVE    C,(TP)          ;SET TO REGOBBLE FLAGS
 907         MOVE    FF,NDIGS(C)
 908 ]
 909         JRST    FINID
 910
 911 ;HERE TO RAP UP CHAR STRING ITEM
 912
 913 MAKSTR: MOVE    C,D             ;SETUP TO CALL CHMAK
 914         PUSHJ   P,CHMAK         ;GO MAKE SAME
 915         JRST    FINID
 916
 917
 918 NUMHAK: MOVE    C,(TP)          ;REGOBBLETEMP POINTER
 919         POP     P,D     ;POP OFF STACK TOP
 920         HRLI    D,(D)   ;TOO BOTH HALVES
 921         SUB     P,D             ;REMOVE CHAR STRING
 922         TRNE    FF,FLONUM+EFLG  ;IS IT A FLOATING POINT NUMBER
 923         JRST    FLOATIT         ;YES, GO MAKE IT WIN
 924         MOVE    B,CNUM(C)
 925         TRNE    FF,DECFRC
 926         MOVE    B,DNUM(C)       ;GRAB FIXED GOODIE
 927 \rFINID2:        MOVSI   A,TFIX          ;SAY FIXED POINT
 928 FINID1: TRNE    FF,NEGF         ;NEGATE
 929         MOVNS   B               ;YES
 930 FINID:  POP     TP,TP           ;RESTORE OLD TP
 931         SUB     TP,[1,,1]       ;FINISH HACK
 932 IFN FRMSIN,[
 933         TRNE    FF,FRSDOT       ;DID . START IT
 934         JRST    .SET            ;YES, GO HACK
 935 ]
 936         POPJ    P,              ;AND RETURN
 937
 938
 939 \fFLOATIT:î      JFCL    17,.+1          ;CLEAR ALL ARITHMETIC FLAGS
 940 \r       TRNE    FF,EFLG ;"E" SEEN?
 941         JRST    EXPDO   ;YES, DO EXPONENT
 942         MOVE    D,NDIGS(C)      ;GET IMPLICIT EXPONENT
 943
 944 FLOATE: MOVE    A,DNUM(C)       ;GET DECIMAL NUMBER\0
 945         IDIVI   A,400000        ;SPLIT
 946         FSC     A,254   ;CONVER\0T MOST SIGNIFICANT
 947         FSC     B,233   ; AND LEAST SIGNIFICANT
 948         FADR    B,A             ;COMBINE
 949
 950         MOVM    A,D             ;GET MAGNITUDE OF EXPONENT
 951         CAILE   A,37.           ;HOW BIG?
 952         JRST    FOOR            ;TOO BIG-FLOATING OUT OF RANGE
 953         JUMPGE  D,FLOAT1        ;JUMP IF EXPONENT POSITIVE
 954         FDVR    B,TENTAB(A)     ;DIVIDE BY TEN TO THE EXPONENT
 955         JRST    SETFLO
 956
 957 FLOAT1: FMPR    B,TENTAB(A)     ;SCALE UP
 958
 959 SETFLO: JFCL    10,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW
 960         MOVSI   A,TFLOAT
 961 IFN FRMSIN,     TRZ     FF,FRSDOT       ;FLOATING NUMBER NOT VALUE
 962         JRST    FINID1
 963
 964 EXPDO:
 965         HRRZ    D,ENUM(C)       ;GET EXPONENT
 966         TRNE    FF,NEGF ;IS EXPONENT NEGATIVE?
 967         MOVNS   D               ;YES
 968         ADD     D,NDIGS(C)      ;ADD IMPLICIT EXPONENT
 969         HLR     FF,ENUM(C)      ;RESTORE FLAGS
 970         JUMPL   D,FLOATE        ;FLOATING IF EXPONENT NEGATIVE
 971         CAIG    D,10.           ;OR IF EXPONENT TOO LARGE
 972         TRNE    FF,FLONUM       ;OR IF FLAG SET
 973         JRST    FLOATE
 974         MOVE    B,DNUM(C)       ;
 975         IMUL    B,ITENTB(D)
 976         JFCL    10,FLOATE               ;IF OVERFLOW, MAKE FLOATING
 977         JRST    FINID2          ;GO MAKE FIXED NUMBER
 978 \f
 979 ; HERE TO READ ONE CHARACTER FOR USER.
 980
 981 INXTRD: SKIPA   E,[JFCL]        ;NULL CLEAR INS
 982 IREADC: MOVE    E,[PUSHJ P,LSTCHR]      ;AVOID RE-READ
 983         PUSHJ   P,NXTC  ;GOBBLE THE CHAR
 984         XCT     E               ;CLEAR LSTCHR IF NECESSARY
 985         CAIN    A,3             ;IS IT EOF?
 986         JRST    EOFCHR          ;DO EOF RETURN
 987         MOVE    B,A             ;CHAR TO B
 988         LSH     B,29.           ;LEFT JUSTIFY
 989         MOVSI   A,TCHRS         ;AND TYPE
 990         JRST    RET
 991
 992 ; READER ERRORS COME HERE
 993
 994 ERRPAR: PUSH    TP,$TCHRS       ;DO THE OFFENDER
 995         LSH     B,29.           ;POSITION IN WORD
 996         PUSH    TP,B
 997         PUSH    TP,$TCHRS
 998         PUSH    TP,[40_29.]             ;SPACE
 999         PUSH    TP,$TATOM
1000         PUSH    TP,MQUOTE WARNING-UNMATCHED
1001         MCALL   1,PRIN1
1002         MCALL   1,PRINC
1003         MCALL   1,PRINC
1004         PUSHJ   P,LSTCHR                ;FLUSH THE CHARACTER
1005         SOS     (P)             ;SIMULATE JRST .-1
1006         SOS     (P)
1007         POPJ    P,
1008
1009 ;COMPLAIN ABOUT MISMATCHED CLOSINGS
1010
1011 MISMAB: SKIPA   A,["]]
1012 MISMAT: MOVE    A,-1(P)         ;GOBBLE THE DESIRED CHARACTER
1013         JUMPE   B,CPOPJ         ;IGNORE UNIVERSAL CLOSE
1014         LSH     A,29.           ;POSITION
1015         PUSH    TP,$TCHRS
1016         PUSH    TP,A
1017         PUSH    TP,$TATOM
1018         PUSH    TP,MQUOTE [ INSTEAD-OF ]
1019         PUSH    TP,$TCHRS
1020         LSH     B,29.
1021         PUSH    TP,B
1022         MCALL   1,PRINC
1023         MCALL   1,PRINC
1024         MCALL   1,PRINC
1025 CPOPJ:  POPJ    P,
1026
1027
1028
1029 ; HERE TO RESET A READ CHANNEL
1030
1031 MFUNCTION RRRES,SUBR,RESET
1032
1033         ENTRY   1
1034         GETYP   A,(AB)
1035         CAIE    A,TCHAN
1036         JRST    WRONGT
1037         MOVE    C,1(AB)         ;GET CHANNEL
1038         MOVEI   B,DIRECT-1(C)   ;POINT TO DIRECTION
1039         PUSHJ   P,CHRWRD                ;CONVER T TO A WORD
1040         JFCL
1041         CAME    B,[ASCII /READ/]
1042         JRST    WRNGDI
1043         MOVE    B,1(AB)         ;RESTORE CHANNEL
1044         SETZM   LSTCH(B)
1045         PUSHJ   P,RRESET"       ;DO REAL RESET
1046         MOVE    A,(AB)          ;RETURN ARG
1047         JRST    FINIS
1048
1049 \f
1050 ; HERE ON BAD INPUT CHARACTER
1051
1052 BADCHR: PUSH    TP,$TATOM
1053         PUSH    TP,MQUOTE BAD CHARACTER IGNORED
1054         MCALL   1,PRINT
1055         JRST    IREAD
1056
1057
1058 ;EOF ERROR
1059
1060 NEOF:   PUSH    TP,$TATOM       ;GENERATE ERROR MESSAGE
1061         PUSH    TP,MQUOTE EOF-REACHED
1062         JRST    CALER1
1063
1064 ;LOSING CHANNEL FOR INPUT
1065
1066 CHNLOS: PUSH    TP,$TATOM
1067         PUSH    TP,MQUOTE BAD-CHANNEL
1068         JRST    CALER1
1069
1070
1071 ;OPEN ERROR
1072
1073 OPNERR: PUSH    TP,$TATOM       ;SETUP MESSAGE
1074         PUSH    TP,MQUOTE OPEN-FAILED
1075         JRST    CALER1
1076
1077 ;HERE FOR DIRECTION ERROR
1078
1079 WRNGDI: PUSH    TP,$TATOM       ;SET UP ERROR
1080         PUSH    TP,MQUOTE NOT-OPEN-FOR-READING
1081         JRST    CALER1
1082
1083 ;WRONG ARG TYPE
1084
1085 WRONGT: PUSH    TP,$TATOM
1086         PUSH    TP,MQUOTE WRONG-TYPE
1087         JRST    CALER1
1088
1089 ;FLOATING POINT NUMBER TOO LARGE OR SMALL
1090 FOOR:   PUSH    TP,$TATOM
1091         PUSH    TP,MQUOTE NUMBER-OUT-OF-RANGE
1092         JRST    CALER1
1093
1094
1095 NILSXP: 0,,0
1096
1097 LSTCHR: PUSH    P,B
1098         MOVE    B,5(TB) ;GET CHANNEL
1099         SETZM   LSTCH(B)
1100         POP     P,B
1101         POPJ    P,
1102
1103
1104
1105 ;TABLE OF NAMES OF ARGS AND ALLOWED TYPES
1106
1107 ARGS:
1108         IRP     A,,[[[CAIN C,TUNBOU],EOF],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]]
1109                 IRP B,C,[A]
1110                         B
1111                         MQUOTE C
1112                         .ISTOP
1113                 TERMIN
1114         TERMIN
1115
1116 CHOBL:  CAIE    C,TLIST ;A LIST OR AN OBLIST
1117         CAIN    C,TOBLS
1118         AOS     (P)
1119         POPJ    P,
1120
1121 END
1122
1123 \f\f\ 3\f