home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / SIMTEL / CPMUG / CPMUG023.ARK / KERNEL.ASM < prev    next >
Assembly Source File  |  1985-07-13  |  39KB  |  2,344 lines
  1. ;INTEL 8080 STOIC KERNEL
  2. ;J. SACHS 3/24/77
  3. ;
  4. ;***************************************************************************
  5. ;** COPYRIGHT (C) MASSACHUSETTS INSTITUTE OF TECHNOLOGY AND HARVARD       **
  6. ;** UNIVERSITY, BIOMEDICAL ENGINEERING CENTER 1977.  ALL RIGHTS RESERVED. **
  7. ;***************************************************************************
  8. ;
  9.  
  10. ;ASSY TIME PARAMETERS
  11. BCKSP    EQU    0    ;TTY = -1 FOR A TERMINAL WITH BACKSPACE
  12.             ;TTY = 0 FOR A TERMINAL WITHOUT BACKSPACE
  13.  
  14. TABS    EQU    0    ;TABS = -1 FOR A TERMINAL WITH HARDWARE TABS
  15.             ;TABS = 0 FOR A TERMINAL WITHOUT HARDWARE TABS
  16.  
  17. DISK    EQU    -1    ;DISK = 0 FOR TAPE
  18.             ;DISK = -1 FOR DISK
  19.  
  20. DEBUG    EQU    -1    ;DEBUG = 0 FOR NO ERROR CHECKING
  21.             ;DEBUG = -1 FOR ERROR CHECKING
  22.  
  23. CPM    EQU    -1    ;CPM    = -1 FOR A CPM COMPATABLE KERNEL
  24.             ;CPM    = 0 FOR ORGINAL KERNEL
  25. ;LOCATIONS OF I/O ROUTINES IN BOOT ROM
  26. ;
  27.  
  28.     IF (DISK) AND (NOT CPM)
  29.  
  30. Q$TTYI    EQU    01F4H    ;TTY INPUT ROUTINE
  31. Q$TTYO    EQU    Q$TTYI+3    ;TTY OUTPUT ROUTINE
  32. DSKIN    EQU    Q$TTYO+3    ;DISK INPUT ROUTINE
  33. DSKOU    EQU    DSKIN+3    ;DISK OUTPUT ROUTINE
  34.  
  35. BSIZE    EQU    1000Q    ;DISK BLOCK SIZE (BYTES)
  36. NBLKS    EQU    1000Q    ;NUMBER OF DISK BLOCKS
  37.  
  38.     ENDIF
  39.  
  40.     IF (NOT DISK) AND (NOT CPM)
  41.  
  42. DSKIN    EQU    201DH
  43. DSKOU    EQU    2018H
  44.  
  45. BSIZE    EQU    2000Q
  46. NBLKS    EQU    1000Q
  47.  
  48.     ENDIF
  49.  
  50. ;PARAMETER DEFINITIONS
  51. ;
  52.     IF NOT CPM
  53.  
  54. SSIZE    EQU    256    ;MAIN STACK SIZE
  55. RSIZE    EQU    64    ;RETURN STACK SIZE
  56. LSIZE    EQU    64    ;LOOP STACK SIZE
  57. VSIZE    EQU    8    ;VOCABULARY STACK SIZE
  58. KSIZE    EQU    82    ;KEYBOARD BUFFER SIZE
  59. CSIZE    EQU    256    ;COMPILE BUFFER SIZE
  60.  
  61. ;RESTART JUMPS
  62.     ORG 2000H
  63.     JMP ABORT    ;RESTART 0
  64.     JMP 0        ;RESTART 1
  65.     JMP 0        ;RESTART 2
  66.     JMP 0        ;RESTART 3
  67.     JMP 0        ;RESTART 4
  68.     JMP 0        ;RESTART 5
  69.     JMP 0        ;RESTART 6
  70.     JMP 0        ;RESTART 7
  71.  
  72.     ENDIF
  73. ;
  74.     IF (NOT DISK) AND (NOT CPM)
  75.  
  76.     ORG 2400H
  77.  
  78. ;DEFINE TTY ADDRESSES
  79. TTYISR    EQU    0E001H        ;TTY INPUT STATUS REGISTER
  80. TTYOSR    EQU    0E002H        ;TTY OUTPUT STATUS REGISTER
  81. TTYIDR    EQU    0E003H        ;TTY INPUT DATA REGISTER
  82. TTYODR    EQU    0E004H        ;TTY OUTPUT DATA REGISTER
  83.  
  84. ;GET CHAR FROM TTY
  85. Q$TTYI:    LDA TTYISR
  86.     ORA A
  87.     JP Q$TTYI
  88.     LDA TTYIDR
  89.     ANI 177Q
  90.     RET
  91.  
  92. ;TYPE A CHARACTER ON TTY
  93. Q$TTYO:    PUSH PSW
  94. TTYO1:    LDA TTYOSR
  95.     ORA A
  96.     JP TTYO1
  97.     POP PSW
  98.     STA TTYODR
  99.     RET
  100.  
  101.     ENDIF
  102. ;
  103. ;/////////////////////////////////////////////////////////////////////
  104. ;
  105. ;DATE 2/21/78
  106. ;
  107. ;
  108. ;ROUTINE: CPMKER
  109. ;PURP:    ALTERNATIONS TO STOIC KERNEL TO RUN UNDER CPM
  110. ;ENTRY: SET CPM ASSEMBLY TIME PARAMETER TO -1=TRUE
  111. ;EXIT:    ADDITIONAL ROUTINES ARE INSERTED INTO THE KERNEL TO 
  112. ;    INTERFACE TO CPM
  113. ;    1) TTYIN
  114. ;    2) TTYOUT
  115. ;    3) DISKIN
  116. ;    4) DISKOUT IS NOT IMPLEMENTED AT THIS TIME
  117. ;    5) RD15 MODIFIED TO IGNORE LINE FEED CHARACTERS
  118. ;    6) CPMLD COMMAND IMPLEMENTED TO READ IN STOIC SOURCE
  119. ;        FILES FROM A CPM DISK
  120. ;        TO USE TYPE
  121. ;            'NAME CPMLD
  122. ;    NOTE THE NAME IS ONLY THE FIRST NAME AND NOT THE EXTENSION
  123. ;      WHICH IS ASSUMED TO BE "STC"
  124. ;    7) RETCPM COMMAND WHICH WILL REBOOT CPM
  125. ;    8) ALSO THE MEMORY WILL BE SET EACH TIME STOIC IS BROUGHT UP
  126. ;        TO THE VALUE @ LOCATION 6 = ADDRESS OF THE BASE OF BDOS
  127. ;    9) SZSTOIC COMPUTES THE # OF 256 BYTE PAGES USED BY STOIC
  128. ;        USED FOR SAVING STOIC
  129. ;    10)CHANGES TO THE ORGINAL KERNEL SO THE KERNEL WILL
  130. ;        ASSEMBLE USING "ASM"
  131. ;        A) ALL ? CHANGED TO Q$
  132. ;        B) ALL MVI A,-1 CHANGED TO MVI A,0FFH
  133. ;        C) ALL MVI M,-1 CHANGED TO MVI M,OFFH
  134. ;
  135. ;
  136. ;/////////////////////////////////////////////////////////////////
  137. ;
  138. ;
  139.     IF CPM
  140. ;
  141. ;BLOCK DEFINITIONS
  142. ;
  143. BSIZE    EQU    400H    ;SIZE OF DISK BLOCK
  144. NBLKS    EQU    77*26*128/BSIZE ;77 TRACKS
  145.                 ;26 SECTORS PER TRACK
  146.                 ;128 BYTES PER SECTOR
  147.                 ;NUMBER OF BLOCKS
  148. ;
  149. ;
  150. ;PARAMETER DEFINITIONS
  151.  
  152. SSIZE    EQU    256    ;MAIN STACK SIZE
  153. RSIZE    EQU    64    ;RETURN STACK SIZE
  154. LSIZE    EQU    64    ;LOOP STACK SIZE
  155. VSIZE    EQU    8    ;VOCABULARY STACK SIZE
  156. KSIZE    EQU    82    ;KEYBOARD BUFFER SIZE
  157. CSIZE    EQU    256    ;COMPILE BUFFER SIZE
  158.  
  159.     ORG    100H
  160. ;
  161. ;ENTER STOIC
  162. TPA:    LXI    SP,SSTACK  ;SET NEW STACK POINTER
  163. ;
  164. ; PICK UP SIZE OF AVAIL MEMORY
  165.     LHLD    BDOS+1    ;GET BEGINING OF BDOS
  166.     SHLD    Q$MEMO    ;STORE IN MEMORY LOCATION
  167.     JMP    ABORT    ;ENTER STOIC
  168. ;
  169. ;
  170. ; BDOS AND IO EQUATES
  171. ;
  172. BDOS    EQU    5    ;ADDRESS OF JMP TO BDOS
  173. CONO    EQU    9    ;DISPLACEMENT TO CONOUT ROUTINE
  174. CONI    EQU    6    ;INDEX INTO CONSOLE CBIOS ROUTINE
  175. BASEIOS    EQU    1    ;LOCATION 1 HAS BASE OF IOS
  176. SELDSK    EQU    14    ;SELECT THE DISK
  177. OPENCPM EQU    15    ;OPEN A CPM FILE
  178. RDNXTREC EQU    20    ;READ NEXT SECTOR
  179. CPMFCB    EQU    5CH    ;DEFUALT FILE CONTROL BLOCK
  180. SETDMA    EQU    26    ;SET DMA ADDRESS
  181. ;
  182. ;
  183. ;
  184. ;TTYIN
  185. Q$TTYI:    LHLD    BASEIOS    ;GET ADDRESS OF IOS
  186.     LXI    D,CONI
  187.     DAD    D
  188.     PCHL    ;JMP TO ROUTINE
  189. ;
  190. ;
  191. ;TTY OUT
  192. Q$TTYO:    ANI    7FH    ;CLEAR MSB
  193.     MOV    C,A    ;PLACE IN REG C
  194.     LHLD    BASEIOS    ;GET BASE OF IOS TABLE
  195.     LXI    D,CONO
  196.     DAD    D    ;HL=ADDRESS OF CONSOLE OUT ROUTINE
  197.     PCHL        ;JMP TO CONO
  198. ;
  199. ;
  200. ;DISK OUTPUT ROUTINE PRESENTLY CAUSES A ERROR
  201.  
  202. DSKOU:    MVI    A,1
  203.     RET
  204. ;
  205. ;DISK INPUT ROUTINE
  206. ;PURP:    INPUT A BLOCK OF DATA [8 SECTORS ] FROM A CPM FILE
  207. ;ENTRY:    HL=BLOCK# IN LOWER 9 BITS [DISCARDED]
  208. ;    THE 10,AND 11 BITS [BIT 1,2 OF HL] = THE UNIT
  209. ;EXIT:    A=0 IF GOOD READ ELSE A=1
  210. ;
  211. ;PROCEDURE
  212. ;
  213. ;
  214. ;SET THE DMA ADDRESS TO POINT TO THE BUFFER
  215. ;    AND READ 8 SECTORS
  216. DSKIN:    MVI    B,BSIZE/128
  217. NXTSEC:    PUSH    B    ;SAVE COUNT
  218.     PUSH    D    ;SAVE DMA ADDRESS
  219.     MVI    C,SETDMA
  220.     CALL    BDOS    ;SET THE DMA ADDRESS
  221.     LXI    D,CPMFCB
  222.     MVI    C,RDNXTREC  ;READ THE NEXT RECORD
  223.     CALL    BDOS    ;READ THE SECTOR
  224.     POP    D
  225.     POP    B    ;RETRIEVE POINTERS
  226.     ORA    A    ;SET FLAGS RETURNED FROM THE READ OPERATION
  227.     JZ    NXTSECCONT
  228.     DCR    A    ;IF ERROR WAS END OF FILE IGNORE
  229.     RET        ;IF ERROR WAS A 2 RET WITH ERROR 1
  230. ;
  231. NXTSECCONT:
  232.     LXI    H,128    ;
  233.     DAD    D
  234.     XCHG        ;DE=NEXT DMA LOCATION
  235.     DCR    B
  236.     JNZ    NXTSEC
  237.     RET
  238. ;
  239. ;
  240. ;/////////////////////////////////////////////////
  241. ;
  242. ;
  243. ;ROUTINE: RET TO CPM
  244. ;PRUP: RETURN TO CPM
  245. ;ENTRY:    NONE
  246. ;EXIT:    NONE
  247. ;PROCEDURE
  248. ;
  249.     DB    6,'RETCP'
  250.     DW    0
  251.     DW    $+2
  252. Q$RETCPM: LHLD     BASEIOS
  253.     PCHL        ;DO A WARM BOOT
  254. ;
  255. ;
  256. ;//////////////////////////////////////////////////
  257. ;
  258. ;
  259. ;
  260. ;ADDITIONAL WORDS TO IMPLEMENT FILE READING
  261. ;
  262. ;
  263. ;//////////////////////////////////////////////////
  264. ;
  265. ;ROUTINE: 0FCB
  266. ;PURP:    FILL A CPM FCB WITH ZERO'S
  267. ;ENTRY:    TOS=FCB ADDRESS
  268. ;EXIT:    TOS=DELETED
  269. ;PROCEDURE
  270. ;
  271.     DB    4,'0FCB'
  272.     DW    Q$RETCPM
  273.     DW    $+2
  274. Q$0FCB:    POP    H    ;FETCH FCB ADDRESS
  275.     MVI    B,33
  276.  
  277. Q$0FCB1:
  278.     MVI    M,0
  279.     INX    H
  280.     DCR    B
  281.     JNZ    Q$0FCB1    ;JIF NOT DONE
  282.     JMP    Q$NEXT
  283. ;
  284. ;///////////////////////////////////////////////////////////
  285. ;
  286. ;
  287. ;
  288. ;OPFILE
  289. ;PURP:    OPEN A CPM FILE
  290. ;ENTRY:    TOS=FCB ADDRESS
  291. ;EXIT:    TOS=0 IF OK
  292. ;    TOS=-1 IF ERROR
  293. ;PROCEDURE
  294.     DB    6,'OPFIL'
  295.     DW    Q$0FCB
  296.     DW    $+2
  297. Q$OPFILE: LDA    Q$UNIT    ;GET THE UNIT
  298.     MOV    E,A
  299.     MVI    C,SELDSK
  300.     CALL    BDOS
  301.     POP    D    ;GET FCB ADDRESS
  302.     MVI    C,OPENCPM
  303.     CALL    BDOS    ;OPEN FILE
  304.     INR    A
  305.     JNZ    Q$NEXT    ;JIF NO ERRORS
  306.     LXI    H,OPENERR
  307.     JMP    ERROR
  308. ;
  309. ;OPEN ERROR MESSAGE
  310. OPENERR: DB    15,'OPEN FILE ERROR',0
  311. ;
  312. ;
  313. ;
  314. ;////////////////////////////////////////
  315. ;
  316. ;ROUTINE DFTFCB
  317. ;PURP:    PUSH THE ADDRESS OF THE DEFUALT ON TO THE TOS
  318. ;ENTRY:    NONE
  319. ;EXIT:    TOS=DEFUALT FCB
  320. ;PROCEDURE
  321. ;
  322.     DB    6,'DFTFC'    ;DEFUALT FCB
  323.     DW    Q$OPFILE
  324.     DW    Q$CONS
  325. Q$DFTFCB: DW    CPMFCB
  326. ;
  327. ;//////////////////////////////////////////////
  328. ;
  329. ;ROUTINE: STORE A FILE NAME IN THE FCB
  330. ;PURP:
  331. ;ENTRY: TOS=FCB,NAME
  332. ;EXIT:    TOS=DELETED
  333. ;PROCEDURE
  334. ;
  335.     DB    6,'STNAM'    ;STORENAME
  336.     DW    Q$DFTFCB
  337.     DW    $+2
  338. Q$STNAME: POP    D    ;GET DESTINATION
  339.     POP    H    ;GET SOURCE
  340.     MOV    A,M    ;GET LENGTH OF SOURCE
  341.     MOV    B,A    ;PLACE IN B
  342.     CPI    9    ;TEST FOR PROPER LENGTH
  343.     JC    STN1    ;JIF OK
  344.     LXI    H,BADNAME  ;ELSE ERROR EXIT
  345.     JMP    ERROR
  346. ;
  347. ;FIRST MOVE THE DEFUALT EXTENSION ".STC" AND CLEAR THE NAME
  348. ;  THE MOVE IN THE NAME
  349. STN1:    PUSH    H
  350.     PUSH    D
  351.     MVI    C,2    ;C=COUNTER TO DETERMINE WHEN THE NAME IS MOVED
  352.     LXI    H,DFEXT    ;HL=DEFUALT CLEARED NAME AND .EXT
  353. STN2:    MOV    B,M    ;FETCH COUNT
  354. STN3:    INX    D    ;NEXT FCB
  355.     INX    H    ;NEXT SOURCE
  356.     MOV    A,M
  357.     STAX    D
  358.     DCR    B    ;DEC COUNT
  359.     JNZ    STN3    ;JIF NOT DONE
  360.     DCR    C    ;DEC C TO CHECK IF WE HAVE MOVED THE NAME
  361.     JZ    Q$NEXT    ;JIF WE HAVE
  362.     POP    D
  363.     POP    H
  364.     JMP    STN2    ;ELSE MOVE THE NAME NOW
  365.             ;SINCE THE EXTENION IS IN
  366. ;
  367. ;
  368. ;BADNAME MESSAGE
  369. BADNAME: DB    19,'FILENAME LENGTH > 8',0
  370. ;DEFUALT EXTENSION WITH BLANK FILE NAME
  371. DFEXT:    DB    11,'        STC',0
  372. ;
  373. ;
  374. ;/////////////////////////////////////////////////////
  375. ;
  376. ;ROUTINE: CPMLD
  377. ;PRUP: LOAD A CPM FILE
  378. ;ENTRY: TOS=NAME
  379. ;EXIT:    TOS=DELETED
  380. ;PROCEDURE
  381. ;
  382.     DB    5,'CPMLD'
  383.     DW    Q$STNAME
  384.     DW    Q$COLN
  385. Q$CPMLD:    DW    Q$DFTFCB
  386.     DW    Q$0FCB    ;0 THE FILE CONTROL BLOCK
  387.     DW    Q$DFTFCB
  388.     DW    Q$STNAME    ;STORE NAME IN DFTFCB
  389.     DW    Q$DFTFCB ;GET ADDRESS OF DEFUALT FCB
  390.     DW    Q$OPFILE    ;OPEN THE FILE
  391.     DW    EBUF    ;EMPTY THE BUFFERS
  392.     DW    LIT
  393.     DW    1    ;DUMMY BLOCK 1
  394.     DW    LOAD    ;LOAD THE FILE
  395.     DW    Q$SEMI    ;RETURN
  396. ;
  397. ;
  398.     ENDIF
  399. ;
  400. ;
  401. ;/////////////////////////////////////////////////////////////
  402. ;
  403. ;
  404. ;INTERPRETER
  405. ;
  406.     DW $+2
  407. PUSH0:    LXI H,0        ;0PUSH
  408.     JMP Q$Q$PUSH
  409.  
  410.     DW $+2
  411. PUSH1:    LXI H,-1    ;-1PUSH
  412.     JMP Q$Q$PUSH
  413.  
  414. Q$DPUSH:    PUSH D        ;DPUSH
  415. Q$Q$PUSH:    PUSH H        ;PUSH
  416. Q$NEXT:
  417.     IF DEBUG
  418.     LXI H,-(SSTACK+1)
  419.     DAD SP
  420.     JC STKE1
  421.     LXI H,-SSTKE
  422.     DAD SP
  423.     JNC STKE2
  424.     ENDIF
  425.     LHLD Q$I        ;NEXT
  426.     INX H
  427.     INX H
  428.     SHLD Q$I
  429.     MOV E,M
  430.     INX H
  431.     MOV D,M
  432. NEXT1:    MOV H,D
  433.     MOV L,E
  434.     DCX H
  435.     MOV A,M
  436.     DCX H
  437.     MOV L,M
  438.     MOV H,A
  439.     PCHL
  440.  
  441.     IF DEBUG
  442. STKE1:    LXI H,SERM1
  443.     JMP ERROR
  444. STKE2:    LXI H,SERM2
  445.     JMP ERROR
  446. SERM1:    DB 11,'STACK EMPTY'
  447. SERM2:    DB 10,'STACK FULL'
  448.     ENDIF
  449. ;
  450. ;
  451. ;TTY INPUT ROUTINE (JUMPS TO ADDRESS IN Q$TYI)
  452. ;
  453. ;    CALL TTYIN
  454. ;    CHARACTER RETURNED IN A
  455.  
  456. TTYIN:    LHLD Q$TYI
  457.     PCHL
  458.  
  459. ;TTY OUTPUT ROUTINE (JUMPS TO ADDRESS IN Q$TYO)
  460. ;
  461. ;    CHARACTER IN A
  462. ;    CALL TTYOU
  463.  
  464. TTYOU:    LHLD Q$TYO
  465.     PCHL
  466.  
  467.     DW $+2
  468. Q$SEMI:    LHLD Q$R        ;RETURN STACK PTR
  469.     MOV E,M        ;GET TOP OR STACK INTO DE
  470.     INX H
  471.     MOV D,M
  472.     DCX H
  473.     DCX H        ;DECREMENT RETURN STACK PTR BY 2
  474.     DCX H
  475.     SHLD Q$R
  476.     XCHG        ;MOVE RESULT TO HL
  477.     SHLD Q$I        ;SET .I
  478.     JMP Q$NEXT
  479.  
  480.     DW $+2
  481. Q$SCOD:    LHLD Q$CURR    ;(;CODE<)
  482.     MOV E,M
  483.     INX H
  484.     MOV D,M
  485.     DCX D
  486.     DCX D
  487.     LHLD Q$I
  488.     INX H
  489.     INX H
  490.     XCHG
  491.     MOV M,E
  492.     INX H
  493.     MOV M,D
  494.     JMP Q$SEMI
  495.  
  496.     DB 2,'()',0,0,0        ;()
  497. ;LINK TO CPM WORDS IF CPM=-1
  498.     IF CPM
  499.     DW Q$CPMLD
  500.     ENDIF
  501. ;
  502. ;ELSE THIS WILL BE THE END OF THE DICTIONARY
  503.     IF NOT CPM
  504.     DW 0
  505.     ENDIF
  506. ;
  507.     DW $+2
  508. LIT:    LHLD Q$I        ;INCREMENT .I BY 2
  509.     INX H
  510.     INX H
  511.     SHLD Q$I
  512. ATPUS:    MOV E,M        ;@PUSH
  513.     INX H
  514.     MOV D,M
  515. PUSHD:    PUSH D        ;PUSHD
  516.     JMP Q$NEXT
  517.  
  518.     DB 3,'S()',0,0        ;S()
  519.     DW LIT
  520.     DW $+2
  521. SLIT:    LHLD Q$I
  522.     INX H
  523.     INX H
  524.     MVI D,0
  525.     MOV E,M
  526.     PUSH H
  527.     DAD D
  528.     SHLD Q$I
  529.     JMP Q$NEXT
  530.  
  531.     DB 5,'ABORT'    ;ABORT
  532.     DW SLIT
  533.     DW $+2
  534. ABORT:    LXI SP,SSTACK    ;RESET STACK PTR
  535.     LXI H,RSTACK    ;RESET RETURN STACK PTR
  536.     SHLD Q$R
  537.     LXI H,LSTACK    ;RESET LOOP STACK PTR
  538.     SHLD Q$Q$L
  539.     LXI H,-1    ;SET INBLK TO -1 (READ FROM KEYBOARD)
  540.     SHLD Q$INBLK
  541.     CALL Q$Q$AB    ;CALL USER ABORT ROUTINE
  542.     LXI H,GO-2    ;SET .I TO GO-2
  543.     SHLD Q$I
  544.     JMP Q$NEXT    ;START IT UP
  545.  
  546. Q$Q$AB:    LHLD Q$ABORT    ;JMP TO ABORT ROUTINE ADDRESS
  547.     PCHL
  548.  
  549.     IF DEBUG
  550. ;TEST FOR DICTIONARY FULL
  551. DICTF:    LHLD Q$MEMO    ;END OF MEMORY
  552.     LXI D,-100    ;-100 FOR SAFETY
  553.     DAD D
  554.     CALL Q$MHL
  555.     XCHG
  556.     LHLD Q$Q$D    ;DICTIONARY POINTER
  557.     DAD D
  558.     RNC
  559.     LXI H,DER2    ;DICTIONARY FULL
  560.     JMP ERROR
  561.  
  562. DER2:    DB 15,'DICTIONARY FULL'
  563.  
  564. ;TEST FOR COMPILE BUFFER FULL
  565. CBF:    LHLD Q$C        ;COMPILE BUFFER PTR
  566.     LXI D,-KBUF    ;START OF LINE BUFFER
  567.     DAD D
  568.     RNC
  569.     LXI H,CER2    ;COMPILE BUFFER FULL
  570.     JMP ERROR
  571.  
  572. CER2:    DB 19,'COMPILE BUFFER FULL'
  573.  
  574.     ENDIF
  575. ;
  576. ;
  577. ;
  578. Q$MHL:    DCX H    ;-HL
  579. Q$NHL:    MOV A,H        ;NOTHL
  580.     CMA
  581.     MOV H,A
  582.     MOV A,L
  583.     CMA
  584.     MOV L,A
  585. Q$AB:    RET        ;DEFAULT ABORT ROUTINE
  586.  
  587. ;MULTIPLY ROUTINE
  588. ;MULTIPLIES (HL) BY (DE)
  589. ;RESULT RETURNED IN (HLDE)
  590.  
  591. Q$MUL:    PUSH H        ;MUL
  592.     MOV A,L        
  593.     LXI H,0        
  594.     LXI B,8    
  595. MULT1:    DAD H        
  596.     RAL        
  597.     JNC MULT2    
  598.     DAD D        
  599.     ADC B
  600. MULT2:    DCR C        
  601.     JNZ MULT1    
  602.     XTHL        
  603.     MOV L,A        
  604.     MOV A,H        
  605.     MOV H,B        
  606.     MVI C,8    
  607. MULT3:    DAD H        
  608.     RAL
  609.     JNC MULT4
  610.     DAD D
  611.     ADC B
  612. MULT4:    DCR C
  613.     JNZ MULT3
  614.     MOV D,A    
  615.     MOV E,H        
  616.     MOV H,L    
  617.     MOV L,B        
  618.     POP B        
  619.     DAD B        
  620.     JNC MULT5        
  621.     INX D
  622. MULT5:    XCHG        
  623.     RET
  624. ;
  625. ;
  626.     DB 6,'(ELSE'        ;(ELSE)
  627.     DW ABORT
  628.     DW $+2
  629. Q$ELSE:    LHLD Q$I
  630.     INX H
  631.     INX H
  632.     MOV E,M
  633.     INX H
  634.     MOV D,M
  635.     DCX H
  636.     DAD D
  637.     SHLD Q$I
  638.     JMP Q$NEXT
  639.  
  640.     DB 4,'(IF)',0        ;(IF)
  641.     DW Q$ELSE
  642.     DW $+2
  643. Q$IF:    POP H
  644.     MOV A,H
  645.     ORA L
  646.     JZ Q$ELSE
  647.     LHLD Q$I
  648.     INX H
  649.     INX H
  650.     SHLD Q$I
  651.     JMP Q$NEXT
  652.  
  653.     DB 1,'.',0,0,0,0    ;.
  654.     DW Q$IF
  655.     DW $+2
  656. PERIO:    LHLD Q$Q$D
  657.     JMP Q$Q$PUSH
  658.  
  659.     DB 5,'STATE'        ;STATE
  660.     DW PERIO
  661.     DW Q$CONS
  662. STATE:    DW Q$STATE
  663. ;
  664. ;
  665. ;OUTPUT A CHARACTER TO TTY
  666. ;
  667. ;    A    ASCII CHARACTER CODE
  668. ;    CALL Q$TTO
  669. ;
  670. ;OUTPUT A CR TO TTY
  671. ;
  672. ;    CALL Q$CR
  673. ;
  674. ;OUTPUT A CR IF COLUMN NON-ZERO
  675. ;
  676. ;    CALL Q$IFCR
  677.  
  678. Q$IFCR:    LDA Q$COLU
  679.     ORA A
  680.     RZ
  681. Q$CR:    MVI A,15Q
  682. Q$TTO:    LXI H,Q$COLU    ;INCREMENT COLUMN
  683.     INR M
  684.  
  685.     IF NOT TABS
  686.     CPI 11Q        ;TAB Q$
  687.     JZ TTO2
  688.     ENDIF
  689.  
  690. TTO1:    PUSH PSW    ;SAVE CHARACTER
  691.     CALL TTYOU    ;OUTPUT IT
  692.     POP PSW        ;RESTORE CHARACTER
  693.     CPI 15Q        ;RETURN Q$
  694.     RNZ        ;NO, DONE
  695.     SUB A        ;RESET COLUMN TO 0
  696.     STA Q$COLU
  697.     MVI A,12Q    ;OUTPUT A LINE FEED
  698.     JMP TTO1
  699.  
  700.     IF NOT TABS
  701. TTO2:    MVI A,40Q    ;OUTPUT A SPACE
  702.     CALL TTYOU
  703.     LDA Q$COLU    ;GET COLUMN #
  704.     ANI 7        ;0 MOD 8 Q$
  705.     RZ        ;YES, DONE
  706.     MVI A,11Q    ;NO, INCREMENT COLUMN AND DO ANOTHER SPACE
  707.     JMP Q$TTO
  708.     ENDIF
  709.  
  710. ;TYPE A MESSAGE ON TTY
  711. ;
  712. ;    H    PTR TO STRING
  713. ;    CALL Q$MSG
  714.  
  715. Q$MSG:    MOV A,M        ;GET BYTE COUNT IN A REGISTER
  716. MSG1:    ORA A        ;LENGTH = 0 Q$
  717.     RZ        ;YES, RETURN
  718.     DCR A        ;DECREMENT COUNT
  719.     PUSH PSW    ;SAVE IT
  720.     INX H        ;INCREMENT PTR
  721.     PUSH H        ;SAVE IT
  722.     MOV A,M        ;GET NEXT BYTE
  723.     CALL Q$TTO    ;TYPE IT
  724.     POP H        ;RESTORE PTR AND COUNT
  725.     POP PSW
  726.     JMP MSG1    ;CONTINUE
  727. ;
  728. ;
  729. ;DICTIONARY LOOKUP
  730.     DB 6,'LOOKU'    ;LOOKUP
  731.     DW STATE
  732.     DW $+2
  733. LOOKU:    POP H        ;PTR TO STRING
  734.     SHLD Q$T1
  735.     LHLD Q$V        ;VOCABULARY STACK PTR
  736. LOOK0:    SHLD Q$T3
  737.     LXI D,-(VSTACK)
  738.     DAD D
  739.     MOV A,H
  740.     ORA L
  741.     JZ Q$Q$PUSH    ;YES, LOSE
  742.     LHLD Q$T3
  743.     MOV E,M
  744.     INX H
  745.     MOV D,M
  746.     XCHG
  747.     MOV E,M
  748.     INX H
  749.     MOV D,M
  750.     XCHG
  751.     MOV A,H
  752.     ORA L
  753.     JZ LOOK4    ;EMPTY BRANCH
  754. LOOK1:    LXI D,-10    ;BACK UP TO FIRST BYTE OF NAME
  755.     DAD D
  756.     SHLD Q$T2
  757.     XCHG
  758.  
  759.     LHLD Q$T1    ;CHECK LENGTH BYTE
  760.     LDAX D
  761.     ANI 177Q    ;AND OFF PRECEDENCE
  762.     CMP M
  763.     JNZ LOOK3    ;LENGTH BYTE DIFFERENT
  764.  
  765.     MVI C,5        ;CHECK NEXT 5 CHARACTERS
  766. LOOK5:    INX D        ;INCREMENT POINTERS
  767.     INX H
  768.     LDAX D        ;COMPARE BYTES
  769.     CMP M
  770.     JNZ LOOK3    ;NO MATCH
  771.     ORA A
  772.     JZ LOOK2    ;BYTES EQUAL AND ZERO
  773.     DCR C
  774.     JNZ LOOK5
  775.  
  776. LOOK2:    LHLD Q$T2    ;MATCH
  777.     LXI D,10
  778.     DAD D
  779.     PUSH H        ;PUSH PTR TO ENTRY
  780.     JMP PUSH1    ;PUSH -1
  781.  
  782. LOOK3:    LHLD Q$T2    ;LINK TO NEXT ENTRY
  783.     LXI D,6
  784.     DAD D
  785.     MOV E,M
  786.     INX H
  787.     MOV D,M
  788.     XCHG
  789.     MOV A,H
  790.     ORA L
  791.     JNZ LOOK1
  792. LOOK4:    LHLD Q$T3    ;LINK IS ZERO
  793.     DCX H        ;GO TO NEXT BRANCH
  794.     DCX H
  795.     JMP LOOK0
  796. ;
  797. ;
  798.     DB 2,'B,',0,0,0        ;B,
  799.     DW LOOKU
  800.     DW $+2
  801. BCOMA:    POP H
  802.     MOV A,L
  803.     CALL Q$BCOM
  804.     JMP Q$NEXT
  805.  
  806.     DB 1,',',0,0,0,0    ;,
  807.     DW BCOMA
  808.     DW $+2
  809. COMMA:    POP H
  810.     CALL Q$COMM
  811.     JMP Q$NEXT
  812.  
  813.     DB 2,'C,',0,0,0        ;C,
  814.     DW COMMA
  815.     DW $+2
  816. CCOMM:    POP H
  817.     CALL Q$CCOM
  818.     JMP Q$NEXT
  819.  
  820. Q$COMM:    PUSH H
  821.     MOV A,L
  822.     CALL Q$BCOM
  823.     POP H
  824.     MOV A,H
  825.     CALL Q$BCOM
  826.     RET
  827.  
  828. Q$BCOM:    LHLD Q$Q$D
  829.     MOV M,A
  830.     INX H
  831.     SHLD Q$Q$D
  832.     IF DEBUG
  833.     CALL DICTF
  834.     ENDIF
  835.     RET
  836.  
  837. Q$CCOM:    PUSH H
  838.     MOV A,L
  839.     CALL Q$CBCO
  840.     POP H
  841.     MOV A,H
  842.     CALL Q$CBCO
  843.     RET
  844.  
  845. Q$CBCO:    LHLD Q$C
  846.     MOV M,A
  847.     INX H
  848.     SHLD Q$C
  849.     IF DEBUG
  850.     CALL CBF
  851.     ENDIF
  852.     RET
  853. ;
  854. ;
  855.     DB 6,'RDLIN'    ;RDLINE
  856.     DW CCOMM
  857.     DW $+2
  858. RDLIN:    LXI H,KBUF+1    ;KEYBOARD BUFFER ADDRESS + 1
  859.     SHLD Q$T2    ;CURRENT OUTPUT PTR
  860.     SHLD Q$INP    ;SET INP
  861.  
  862.     SUB A        ;ZERO EOL,BUFFER MODIFIED FLAG
  863.     STA Q$EOL
  864.     STA Q$T1
  865.     CMA        ;SET EOC TO -1
  866.     STA Q$EOC
  867.  
  868.     LHLD Q$INBLK    ;READING FROM FILE Q$
  869.     INX H
  870.     MOV A,H
  871.     ORA L
  872.     JNZ RDL9    ;YES
  873.  
  874. ;READING FROM TTY
  875. RDL1:    CALL TTYIN    ;GET NEXT CHAR
  876.     CPI 12Q        ;LINE FEED
  877.     JZ RDL8
  878.     CPI 177Q
  879.     JZ RDL2        ;RUBOUT
  880.     ORA A
  881.     JZ RDL3        ;NULL
  882.     CPI 15Q        ;CR
  883.     JZ RDL10
  884.     CPI 14Q        ;FF
  885.     JZ RDL10
  886. RDL4:    PUSH PSW    ;ECHO CHARACTER
  887.     CALL Q$TTO
  888.     MVI A,0FFH    ;SET BUFFER MODIFIED FLAG TO -1
  889.     STA Q$T1
  890.     POP PSW
  891.     CALL OCH    ;STORE CHAR IN BUFFER
  892.     LXI D,-(KBUF+KSIZE)
  893.     DAD D
  894.     JNC RDL1
  895. RDL5:    LXI H,RDL6    ;BUFFER FULL
  896.     JMP ERROR
  897. RDL6:    DB 13,'LINE TOO LONG'
  898.  
  899. ;PROCESS RUBOUT
  900. RDL2:    LHLD Q$T2    ;OUTPUT PTR
  901.     LXI D,-(KBUF+1)    ;START OF BUFFER
  902.     DAD D
  903.     MOV A,H
  904.     ORA L
  905.     JZ RDL1        ;BUFFER EMPTY, IGNORE RUBOUT
  906.     LHLD Q$T2    ;BACK UP OUTPUT PTR
  907.     DCX H
  908.     SHLD Q$T2
  909.  
  910.     IF BCKSP
  911.     MVI A,10Q    ;ECHO BACKSPACE, SPACE, BACKSPACE
  912.     CALL Q$TTO
  913.     MVI A,40Q
  914.     CALL Q$TTO
  915.     MVI A,10Q
  916.     CALL Q$TTO
  917.     ENDIF
  918.  
  919.     IF NOT BCKSP
  920.     MVI A,137Q    ;ECHO _
  921.     CALL Q$TTO
  922.     ENDIF
  923.  
  924.     JMP RDL1
  925.  
  926. ;PROCESS NULL
  927. RDL3:    LXI H,KBUF+1    ;RESET OUTPUT PTR
  928.     SHLD Q$T2
  929. ;PROCESS CR OR FF
  930. RDL10:    CALL Q$CR    ;ECHO A CR
  931. RDL11:    SUB A        ;OUTPUT A NULL TO LINE BUFFER
  932.     LHLD Q$T2
  933.     MOV M,A
  934.     LXI D,-(KBUF+1)    ;COMPUTE BYTE COUNT
  935.     DAD D
  936.     MOV A,L
  937.     STA KBUF    ;STORE IN 1ST BYTE OF LINE BUFFER
  938.     JMP Q$NEXT
  939.  
  940. ;PROCESS LINE FEED
  941. RDL8:    LDA Q$T1        ;BUFFER MODIFIED Q$
  942.     ORA A
  943.     JNZ RDL1    ;YES, IGNORE LINE FEED
  944.     CALL Q$CR    ;ECHO A CR
  945.     JMP Q$NEXT    ;AND RE-EXECUTE LINE
  946.  
  947. RDL9:    LHLD Q$INBLK    ;GET INBLK
  948.     XCHG
  949.     CALL RBLK    ;GET ADDR OF BUFFER CONTAINING BLOCK
  950.     PUSH D        ;SAVE IT
  951.     LHLD Q$INBYT    ;GET INBYTE
  952.     PUSH H        ;SAVE IT
  953.     INX H        ;INCREMENT IT
  954.     SHLD Q$INBYT
  955.     LXI D,-BSIZE
  956.     DAD D
  957.     MOV A,H
  958.     ORA L
  959.     JNZ RDL15
  960.     LHLD Q$INBLK    ;INCREMENT INBLK
  961.     INX H
  962.     SHLD Q$INBLK
  963.     LXI H,0        ;RESET INBYTE
  964.     SHLD Q$INBYT
  965. RDL15:    POP D
  966.     POP H
  967.     DAD D
  968.     MOV A,M        ;GET CHAR FROM FILE
  969. ;
  970. ;**********************************
  971. ;
  972. ; THIS CHECK FOR LF IS ADDED BY WINK SAVILLE SO 
  973. ;   FILES MADE UNDER CPM WHICH WILL HAVE LF IN THEM WILL WORK
  974. ;
  975. ;
  976.     IF CPM
  977. ;
  978.     CPI 0AH        ;CHECK FOR A LINE FEED
  979.     JZ RDL9        ;JIF LF
  980.               ;IGNORE LINE FEED
  981.     ENDIF
  982. ;
  983. ;
  984. ;***********************************
  985. ;
  986.     CPI 15Q        ;CR
  987.     JZ RDL11
  988.     CPI 14Q        ;FF
  989.     JZ RDL11
  990.     CPI 4        ;EOF Q$
  991.     JZ RDL12    ;YES, ERROR
  992.     CALL OCH    ;STORE CHAR IN BUFFER
  993.     LXI D,-(KBUF+KSIZE)
  994.     DAD D
  995.     JNC RDL9
  996.     JMP RDL5    ;LINE TOO LONG
  997.  
  998. RDL12:    LXI H,RDL13    ;END OF FILE
  999.     JMP ERROR
  1000. RDL13:    DB 3,'EOF'
  1001.  
  1002. ;OUTPUT A CHARACTER TO LINE BUFFER
  1003. OCH:    LHLD Q$T2
  1004.     MOV M,A
  1005.     INX H
  1006.     SHLD Q$T2
  1007.     RET
  1008.  
  1009. ;
  1010. ;
  1011.     DW $+2
  1012. UNDEF:    POP H    ;WAS IF A LITERAL Q$
  1013.     MOV A,H
  1014.     ORA L
  1015.     JNZ Q$NEXT    ;YES, OK
  1016.     LXI H,UND1
  1017. ERROR:    LXI SP,SSTACK    ;RESET PARAMETER STACK POINTER
  1018.     PUSH H        ;PUSH PTR TO STRING
  1019.     LXI H,RSTACK    ;RESET RETURN STACK POINTER
  1020.     SHLD Q$R
  1021.     LXI H,LSTACK    ;RESET LOOP STACK POINTER
  1022.     SHLD Q$Q$L
  1023.     JMP ERR        ;EXECUTE ERROR HANDLER
  1024.  
  1025. UND1:    DB 9,'UNDEFINED'
  1026.  
  1027.     DB 3,'ERR',0,0    ;ERR
  1028.     DW RDLIN
  1029.     DW $+2
  1030. ERR:    LHLD Q$ERRM    ;ERRMSG @ EXEC
  1031. EXEC:    XCHG
  1032.     JMP NEXT1
  1033.  
  1034.     DB 7,'ERRMS'    ;ERRMSG0
  1035.     DW ERR
  1036.     DW $+2
  1037. ERRM0:    CALL Q$IFCR    ;TYPE A CR IF COLUMN NON-ZERO
  1038.     POP H        ;TYPE THE MESSAGE
  1039.     CALL Q$MSG
  1040.     CALL Q$CR    ;TYPE A CR
  1041.     LHLD Q$Q$D    ;TYPE THE LAST TOKEN
  1042.     CALL Q$MSG
  1043.     CALL Q$IFCR    ;TYPE A CR IF COLUMN NON-ZERO
  1044.     LHLD Q$INBLK    ;INBLK = -1 Q$
  1045.     INX H
  1046.     MOV A,H
  1047.     ORA L
  1048.     JZ ABORT    ;YES, EXECUTING FROM KEYBD
  1049.     LXI H,KBUF    ;NO, TYPE LINE BUFFER
  1050.     CALL Q$MSG
  1051.     CALL Q$CR    ;TYPE A CR
  1052.     JMP ABORT    ;ABORT
  1053. ;
  1054. ;
  1055.     DB 4,'UNIT',0        ;UNIT
  1056.     DW ERRM0
  1057.     DW Q$CONS
  1058. UNIT:    DW Q$UNIT
  1059.  
  1060.     IF DISK
  1061. SETUP:
  1062. ;    MOV A,L        ;TEST FOR ILLEGAL BLOCK #
  1063. ;    SUI NBLKS AND 0FFH
  1064. ;    MOV A,H
  1065. ;    SBI NBLKS/100H
  1066. ;    JNC IBN        ;ILLEGAL BLOCK #
  1067.     LXI B,1        ;SET BLOCK COUNT TO 1
  1068.     RET
  1069.  
  1070. ;IBN:    LXI H,IBNM
  1071. ;    JMP ERROR
  1072.  
  1073. WRERC:    CALL SETUP
  1074. Q$WRERC:    CALL DSKOU
  1075.     RZ        ;NO ERRORS
  1076.     CPI 4        ;WRITE PROTECTED Q$
  1077.     JNZ RDER1    ;NO, CHECK FOR OTHER ERRORS
  1078.     LXI H,WRER1    ;WRITE PROTECTED
  1079.     JMP ERROR
  1080.  
  1081. RDERC:    CALL SETUP
  1082. Q$RDERC:    CALL DSKIN
  1083.     RZ        ;NO ERRORS
  1084. RDER1:    LXI H,RDER2    ;CRC ERROR
  1085.     JMP ERROR
  1086.  
  1087. WRER1:    DB 20,'DISK WRITE PROTECTED'
  1088. RDER2:    DB 10,'DISK ERROR'
  1089. IBNM:    DB 15,'ILLEGAL BLOCK #'
  1090.     ENDIF
  1091.  
  1092.     IF NOT DISK
  1093. WRERC:    LXI B,1        ;WRITE 1 BLOCK
  1094. Q$WRERC:    CALL DSKOU    ;WRITE WITH ERROR CHECKING
  1095.     RZ
  1096.     JMP RDER1
  1097.  
  1098. RDERC:    LXI B,1        ;READ 1 BLOCK
  1099. Q$RDERC:    CALL DSKIN    ;READ WITH ERROR CHECKING
  1100.     RZ        ;IF 0, NO ERROR
  1101. RDER1:    DCR A
  1102.     MOV E,A
  1103.     MVI D,0
  1104.     LXI H,TERRT
  1105.     DAD D
  1106.     DAD D
  1107.     MOV E,M
  1108.     INX H
  1109.     MOV D,M
  1110.     XCHG
  1111.     JMP ERROR
  1112.  
  1113. TERRT:    DW TERR1
  1114.     DW TERR2
  1115.     DW TERR3
  1116.     DW TERR4
  1117.     DW TERR5
  1118.     DW TERR6
  1119.     DW TERR7
  1120.     DW TERR8
  1121.     DW TERR9
  1122.     DW TERRA
  1123.     DW TERRB
  1124.  
  1125. TERR1:    DB 14,'TAPE NOT READY'
  1126. TERR2:    DB 20,'TAPE WRITE PROTECTED'
  1127. TERR3:    DB 22,'READ AFTER WRITE ERROR'
  1128. TERR4:    DB 13,'READ OVERFLOW'
  1129. TERR5:    DB 15,'POSTAMBLE ERROR'
  1130. TERR6:    DB 11,'SHORT BLOCK'
  1131. TERR7:    DB 10,'LONG BLOCK'
  1132. TERR8:    DB 3,'EOT'
  1133. TERR9:    DB 3,'BOT'
  1134. TERRA:    DB 14,'CHECKSUM ERROR'
  1135. TERRB:    DB 12,'NO SUCH TAPE'
  1136.     ENDIF
  1137. ;
  1138. ;
  1139.     DB 6,'NEWES'    ;NEWEST
  1140.     DW UNIT
  1141.     DW Q$CONS
  1142. NEWQ$:    DW NEWEST
  1143.  
  1144. ;    (D,E) BLOCK #
  1145. ;    CALL RBLK (WBLK)
  1146. ;    (D,E) BUFFER ADDRESS
  1147.  
  1148. WBLK:    MVI A,0FFH    ;WBLK
  1149.     JMP BLK
  1150. RBLK:    SUB A        ;RBLK
  1151. BLK:    STA FLAG
  1152.     LHLD NEWEST    ;IS BLOCK THE MOST RECENTLY ACCESSED BLOCK Q$
  1153.     MOV A,E
  1154.     CMP M
  1155.     JNZ BLK1    ;NO
  1156.     INX H
  1157.     MOV A,D
  1158.     CMP M
  1159.     JNZ BLK1    ;NO
  1160.     INX H        ;YES, RETURN BUFFER ADDR
  1161.     MOV E,M
  1162.     INX H
  1163.     MOV D,M
  1164.     RET
  1165.  
  1166. BLK1:    LHLD NEWEST    ;SEARCH BUFFER LIST
  1167.     SHLD BUFP
  1168.     XCHG
  1169.     SHLD BLKN
  1170.  
  1171. BLK2:    LHLD BUFP    ;GET LINK TO NEXT BCT
  1172.     LXI D,4
  1173.     CALL LDX
  1174.     MOV A,D
  1175.     ORA E
  1176.     JZ BLK3        ;END OF LIST, MUST READ IN BLOCK
  1177.     LHLD BUFP
  1178.     SHLD PREV
  1179.     XCHG
  1180.     SHLD BUFP
  1181.     MOV E,M        ;GET BLOCK #
  1182.     INX H
  1183.     MOV D,M
  1184.     LHLD BLKN    ;COMPARE WITH REQUESTED BLOCK #
  1185.     MOV A,H
  1186.     CMP D
  1187.     JNZ BLK2    ;NO
  1188.     MOV A,L
  1189.     CMP E
  1190.     JNZ BLK2    ;NO
  1191. BLK6:    LHLD BUFP    ;RELINK BCT'S
  1192.     LXI D,4
  1193.     CALL LDX
  1194.     PUSH D        ;SAVE LINK OF CURRENT BCT
  1195.     LHLD NEWEST    ;RESET LINK OF CURRENT BCT TO NEWEST
  1196.     XCHG
  1197.     LHLD BUFP
  1198.     LXI B,4
  1199.     CALL STX
  1200.     LHLD BUFP    ;SET NEWEST TO CURRENT BCT
  1201.     SHLD NEWEST
  1202.     LHLD PREV    ;STORE SAVED LINK IN LINK OF PREVIOUS BCT
  1203.     POP D
  1204.     LXI B,4
  1205.     CALL STX
  1206.     LHLD BUFP    ;RETURN BUFFER ADDRESS
  1207.     LXI D,2
  1208.     CALL LDX
  1209.     RET
  1210.  
  1211. BLK3:    CALL FBUF    ;FREE A BUFFER
  1212.     LDA FLAG    ;RBLOCK Q$
  1213.     ORA A
  1214.     JNZ BLK7    ;NO
  1215.     LHLD BUFP    ;READ IN BLOCK
  1216.     LXI D,2
  1217.     CALL LDX
  1218.     LHLD BLKN
  1219.     CALL RDERC
  1220. BLK7:    LHLD BLKN    ;STORE BLOCK # IN BCT
  1221.     XCHG
  1222.     LHLD BUFP
  1223.     MOV M,E
  1224.     INX H
  1225.     MOV M,D
  1226.     JMP BLK6    ;RELINK BCT'S
  1227.  
  1228. FBUF:    LHLD BUFP    ;REEE A BUFFER
  1229.     LXI D,6        ;GET MODIFIED FLAG
  1230.     CALL LDX
  1231.     MOV A,D
  1232.     ORA E
  1233.     RZ        ;NOT MODIFIED, RETURN
  1234.     LHLD BUFP    ;GET BLOCK #
  1235.     MOV E,M
  1236.     INX H
  1237.     MOV D,M
  1238.     PUSH D
  1239.     LHLD BUFP    ;GET BUFFER ADDR
  1240.     LXI D,2
  1241.     CALL LDX
  1242.     POP H
  1243.     CALL WRERC    ;WRITE IT BACK OUT
  1244.     LHLD BUFP    ;CLEAR THE MODIFIED FLAG
  1245.     LXI D,0
  1246.     LXI B,6
  1247.     CALL STX
  1248.     RET        ;RETURN
  1249.  
  1250.     DB 6,'RBLOC'    ;RBLOCK
  1251.     DW NEWQ$
  1252.     DW $+2
  1253. RBLOC:    POP D        ;GET BLOCK #
  1254.     LDA Q$UNIT    ;ADD IN UNIT NUMBER
  1255.     ORA A
  1256.     RAL
  1257.     ORA D
  1258.     MOV D,A
  1259.     CALL RBLK
  1260.     JMP PUSHD
  1261.  
  1262.     DB 6,'WBLOC'    ;WBLOCK
  1263.     DW RBLOC
  1264.     DW $+2
  1265. WBLOC:    POP D
  1266.     LDA Q$UNIT    ;ADD IN UNIT NUMBER
  1267.     ORA A
  1268.     RAL
  1269.     ORA D
  1270.     MOV D,A
  1271.     CALL WBLK
  1272.     PUSH D
  1273.     JMP UPDAT
  1274.  
  1275.     DB 6,'UPDAT'    ;UPDATE
  1276.     DW WBLOC
  1277.     DW $+2
  1278. UPDAT:    LHLD NEWEST    ;SET MODIFIED FLAG ON CURRENT BCT
  1279.     LXI D,-1
  1280.     LXI B,6
  1281.     CALL STX
  1282.     JMP Q$NEXT
  1283.  
  1284.     DB 5,'FLUSH'    ;FLUSH
  1285.     DW UPDAT
  1286.     DW $+2
  1287. FLUSH:    LHLD NEWEST    ;FREE ALL BUFFERS
  1288. FLSH1:    SHLD BUFP
  1289.     CALL FBUF    ;FREE A BUFFER
  1290.     LHLD BUFP    ;LINK TO NEXT BCT
  1291.     LXI D,4
  1292.     CALL LDX
  1293.     MOV A,D
  1294.     ORA E
  1295.     JZ Q$NEXT    ;DONE
  1296.     XCHG        ;DO ANOTHER ONE
  1297.     JMP FLSH1
  1298.  
  1299.     DB 4,'EBUF',0    ;EBUF
  1300.     DW FLUSH
  1301.     DW $+2
  1302. EBUF:    LHLD NEWEST    ;SET ALL BLOCK NUMBERS TO -1
  1303. EBUF1:    SHLD BUFP
  1304.     MVI M,0FFH
  1305.     INX H
  1306.     MVI M,0FFH
  1307.     DCX H
  1308.     LXI D,0
  1309.     LXI B,6
  1310.     CALL STX
  1311.     LHLD BUFP    ;LINK TO NEXT BCT
  1312.     LXI D,4
  1313.     CALL LDX
  1314.     MOV A,D
  1315.     ORA E
  1316.     JZ Q$NEXT    ;DONE
  1317.     XCHG        ;DO ANOTHER ONE
  1318.     JMP EBUF1
  1319.  
  1320. ;INDEXED LOAD
  1321. ;    (DE) OFFSET
  1322. ;    (HL) BASE ADDRESS
  1323. ;    CALL LDX
  1324. ;    (DE) DATA
  1325.  
  1326. LDX:    DAD D
  1327.     MOV E,M
  1328.     INX H
  1329.     MOV D,M
  1330.     RET
  1331.  
  1332. ;INDEXED STORE
  1333. ;    (BC) OFFSET
  1334. ;    (DE) DATA
  1335. ;    (HL) BASE ADDRESS
  1336. ;    CALL STX
  1337.  
  1338. STX:    DAD B
  1339.     MOV M,E
  1340.     INX H
  1341.     MOV M,D
  1342.     RET
  1343. ;
  1344. ;
  1345. ;GET NEXT WORD FROM INPUT STREAM
  1346. ;
  1347. ;ON ENTRY,
  1348. ;Q$INP CONTAINS INPUT POINTER
  1349. ;
  1350. ;ON EXIT,
  1351. ;Q$INP IS UPDATED
  1352. ;TOKEN IS AT END OF DICTIONARY (NULL TERMINATED)
  1353. ;END-OF-LINE FLAG IS ON STACK
  1354. ;
  1355. ;DELIMITER IS SPACE OR TAB UNLESS FIRST CHARACTER IS " OR \
  1356. ;IN WHICH CASE SCANNING CONTINUES UNTIL NEXT " OR \
  1357. ;
  1358. ;IF END-OF-LINE FLAG IS SET ON ENTRY, WORD RETURNS IMMEDIATELY
  1359. ;SCANNING STOPS UNCONDITIONALLY ON A NULL IN THE INPUT STREAM
  1360. ;AND THE END-OF-LINE FLAG IS SET IF THE NULL OCCURED INBETWEEN WORDS;
  1361. ;OTHERWISE IT IS SET ON THE NEXT CALL TO WORD.
  1362.  
  1363.     DB 4,'WORD',0    ;WORD
  1364.     DW EBUF
  1365.     DW $+2
  1366. WORD:    LDA Q$EOL    ;ALREADY AT END OF LINE Q$
  1367.     ORA A
  1368.     JNZ PUSH1    ;YES, RETURN -1
  1369.     LXI B,0920H    ;SET TAB,SPACE AS DELIMITERS (IN (B,C))
  1370.     LHLD Q$Q$D    ;(D,E) IS OUTPUT PTR
  1371.     INX H        ;SKIP LENGTH BYTE
  1372.     XCHG
  1373.     LHLD Q$INP    ;(H,L) IS INPUT PTR
  1374. WORD3:    MOV A,M        ;GET NEXT INPUT CHAR
  1375.     INX H
  1376.     ORA A
  1377.     JZ WORD6    ;NULL, END OF LINE
  1378.     CMP B        ;DELIMITER Q$
  1379.     JZ WORD3    ;YES, IGNORE
  1380.     CMP C
  1381.     JZ WORD3    ;YES, IGNORE
  1382.     CPI 42Q        ;" Q$
  1383.     JZ WORD9
  1384.     CPI 134Q    ;\ Q$
  1385.     JNZ WORD4
  1386. WORD9:    MOV B,A        ;RESET DELIMITERS
  1387.     MOV C,A
  1388. WORD4:    STAX D        ;OUTPUT CHARACTER
  1389.     INX D
  1390.     MOV A,M        ;GET NEXT INPUT CHARACTER
  1391.     INX H
  1392.     ORA A        ;NULL Q$
  1393.     JZ WORD7    ;YES, END OF LINE
  1394.     CMP B        ;DELIMITER Q$
  1395.     JZ WORD8    ;YES, STOP
  1396.     CMP C        ;DELIMITER Q$
  1397.     JNZ WORD4    ;NO, GET MORE CHARACTERS
  1398. WORD8:    SHLD Q$INP    ;UPDATE INPUT PTR
  1399.     SUB A        ;OUTPUT A NULL AT END OF STRING
  1400.     STAX D
  1401.     LHLD Q$Q$D    ;COMPUTE LENGTH OF WORD
  1402.     CALL Q$MHL
  1403.     DAD D
  1404.     MOV A,L
  1405.     DCR A
  1406.     LHLD Q$Q$D    ;STORE IN LENGTH BYTE
  1407.     MOV M,A
  1408.     LDA Q$EOL    ;PUSH END OF LINE FLAG
  1409.     MOV L,A
  1410.     MOV H,A
  1411.     JMP Q$Q$PUSH
  1412.  
  1413. WORD6:    MVI A,0FFH    ;SET EOL TO -1
  1414.     STA Q$EOL
  1415. WORD7:    DCX H        ;DECREMENT INPUT PTR
  1416.     JMP WORD8
  1417. ;
  1418. ;
  1419. ;LITERAL PROCESSOR
  1420.  
  1421.     DB 7,'LITER'    ;LITERAL
  1422.     DW WORD
  1423.     DW Q$COLN
  1424. LITER:    DW PERIO
  1425.     DW ILITE
  1426.     DW Q$IF
  1427.     DW LIT1-2-$
  1428.     DW LIT
  1429.     DW LIT
  1430.     DW CCOMM
  1431.     DW CCOMM
  1432.     DW PUSH1
  1433.     DW Q$SEMI
  1434.  
  1435. LIT1:    DW PERIO
  1436.     DW SLITE
  1437.     DW Q$SEMI
  1438.  
  1439.     DB 8,'ILITE'    ;ILITERAL
  1440.     DW LITER
  1441.     DW $+2
  1442. ILITE:    POP H        ;POP INPUT POINTER
  1443.     INX H
  1444.     SHLD Q$T3    ;SET INPUT PTR
  1445.     LXI H,0        ;ZERO SIGN,VALUE
  1446.     SHLD Q$T4
  1447.     SHLD Q$T5
  1448.  
  1449.     CALL LITG    ;GET NEXT CHAR
  1450.     CPI 53Q        ;"+" Q$
  1451.     JZ ILIT1    ;IGNORE
  1452.     CPI 55Q        ;"-" Q$
  1453.     JNZ ILIT2    ;NO
  1454.     LXI H,-1    ;SET SIGN FLAG
  1455.     SHLD Q$T4
  1456. ILIT1:    CALL LITG    ;GET NEXT CHAR
  1457. ILIT2:    ORA A        ;END OF LITERAL Q$
  1458.     JZ ILIT4    ;YES, DONE
  1459.     CPI 60Q        ;TEST FOR LEGAL DIGIT
  1460.     JC PUSH0    ;ILLEGAL
  1461.     CPI 72Q
  1462.     JC ILIT3
  1463.     CPI 101Q
  1464.     JC PUSH0    ;ILLEGAL
  1465.     SUI 7
  1466. ILIT3:    SUI 60Q
  1467.     LHLD Q$RADIX
  1468.     CMP L
  1469.     JNC PUSH0    ;ILLEGAL
  1470.     STA Q$T1
  1471.     LHLD Q$RADIX    ;MULTIPLY VALUE BY RADIX AND ADD DIGIT
  1472.     XCHG
  1473.     LHLD Q$T5
  1474.     CALL Q$MUL
  1475.     MOV A,H
  1476.     ORA L
  1477.     JNZ PUSH0    ;OVERFLOW
  1478.     LDA Q$T1
  1479.     MOV L,A
  1480.     MVI H,0
  1481.     DAD D
  1482.     SHLD Q$T5    ;SET NEW VALUE
  1483.     JMP ILIT1
  1484.  
  1485. ILIT4:    LHLD Q$T4    ;GET SIGN
  1486.     MOV A,H
  1487.     ORA L
  1488.     LHLD Q$T5    ;GET VALUE
  1489.     CM Q$MHL        ;NEGATE IF SIGN NON-ZERO
  1490.     PUSH H        ;PUSH RESULT
  1491.     JMP PUSH1    ;PUSH -1
  1492.  
  1493.     DB 8,'SLITE'    ;SLITERAL
  1494.     DW ILITE
  1495.     DW $+2
  1496. SLITE:    POP H        ;POP INPUT POINTER
  1497.     INX H
  1498.     SHLD Q$T3    ;SET INPUT PTR
  1499.     CALL LITG    ;GET 1ST CHAR
  1500.     CPI 47Q        ;'
  1501.     JZ SLIT1    ;STRING LITERAL
  1502.     CPI 42Q        ;"
  1503.     JZ SLIT1    ;STRING LITERAL
  1504.     CPI 134Q    ;\
  1505.     JNZ PUSH0    ;ILLEGAL STRING LITERAL
  1506. SLIT1:    LXI H,SLIT    ;OUTPUT S()
  1507.     CALL Q$CCOM
  1508.     LHLD Q$C        ;SAVE PTR TO START OF LITERAL
  1509.     SHLD Q$T1
  1510.     SUB A        ;ZERO LENGTH BYTE
  1511.     CALL Q$CBCO
  1512. SLIT2:    CALL LITG    ;GET NEXT CHAR
  1513.     ORA A
  1514.     JZ SLIT7    ;END OF STRING LITERAL
  1515.     CPI 46Q        ;&
  1516.     JZ SLIT4    ;START OF OCTAL INSERT
  1517. SLIT3:    CALL Q$CBCO    ;OUTPUT CHARACTER
  1518.     LHLD Q$T1    ;INCREMENT LENGTH
  1519.     INR M
  1520.     JMP SLIT2
  1521.  
  1522. SLIT4:    SUB A        ;INITIALIZE VALUE TO 0
  1523. SLIT5:    STA Q$T2
  1524.     CALL LITG    ;GET NEXT CHAR
  1525.     CPI 46Q        ;&
  1526.     JZ SLIT6    ;END OF OCTAL NUMBER
  1527.     CPI 60Q        ;0
  1528.     JM PUSH0    ;ILLEGAL DIGIT
  1529.     CPI 70Q        ;8
  1530.     JP PUSH0    ;ILLEGAL DIGIT
  1531.     SUI 60Q        ;CONVERT TO VALUE
  1532.     MOV B,A
  1533.     LDA Q$T2        ;MULTIPLY VALUE BY 8 AND ADD DIGIT
  1534.     RLC
  1535.     RLC
  1536.     RLC
  1537.     ADD B
  1538.     JMP SLIT5
  1539.  
  1540. SLIT6:    LDA Q$T2        ;RETURN OCTAL VALUE
  1541.     JMP SLIT3
  1542.  
  1543. SLIT7:    CALL Q$CBCO    ;OUTPUT FINAL NULL
  1544.     JMP PUSH1    ;EXIT
  1545.  
  1546. LITG:    LHLD Q$T3    ;GET NEXT INPUT CHAR
  1547.     MOV A,M
  1548.     INX H
  1549.     SHLD Q$T3
  1550.     RET
  1551.  
  1552. ;
  1553.     IF DEBUG
  1554.     DB 6,'ERRCH'    ;ERRCHK
  1555.     DW SLITE
  1556.     DW $+2
  1557. ERRCH:    CALL DICTF
  1558.     CALL CBF
  1559.  
  1560.     LHLD Q$V        ;VOCABULARY STACK PTR
  1561.     XCHG
  1562.     LXI H,-VSTACK-2    ;START OF VOCABULARY STACK + 2
  1563.     DAD D
  1564.     JNC ERRC1
  1565.     LXI H,-LSTACK
  1566.     DAD D
  1567.     JC ERRC2
  1568.  
  1569.     LHLD Q$Q$L    ;LOOP STACK PTR
  1570.     XCHG
  1571.     LXI H,-LSTACK    ;START OF LOOP STACK
  1572.     DAD D
  1573.     JNC ERRC3
  1574.     LXI H,-RSTACK    ;START OF RETURN STACK
  1575.     DAD D
  1576.     JC ERRC4
  1577.     JMP Q$NEXT
  1578.  
  1579. ERRC1:    LXI H,VSTACK+2    ;RESET VOCABULARY STACK PTR
  1580.     SHLD Q$V
  1581.     LXI H,VER1    ;VOCABULARY STACK EMPTY
  1582.     JMP ERROR
  1583. ERRC2:    LXI H,VER2    ;VOCABULARY STACK FULL
  1584.     JMP ERROR
  1585. ERRC3:    LXI H,LER1    ;LOOP STACK EMPTY
  1586.     JMP ERROR
  1587. ERRC4:    LXI H,LER2    ;LOOP STACK FULL
  1588.     JMP ERROR
  1589.  
  1590. VER1:    DB 22,'VOCABULARY STACK EMPTY'
  1591. VER2:    DB 21,'VOCABULARY STACK FULL'
  1592. LER1:    DB 16,'LOOP STACK EMPTY'
  1593. LER2:    DB 15,'LOOP STACK FULL'
  1594.     ENDIF
  1595.  
  1596.     DW Q$COLN
  1597. COMPI:    DW WORD        ;GET NEXT WORD FROM INPUT STREAM
  1598.     DW Q$IF
  1599.     DW COMP1-2-$
  1600.     DW Q$SEMI    ;END OF LINE, RETURN
  1601.  
  1602. COMP1:    DW PERIO    ;DO A DICTIONARY LOOKUP
  1603.     DW LOOKU
  1604.     DW Q$IF
  1605.     DW COMP2-2-$
  1606.     DW Q$COMP    ;FOUND, COMPILE OR EXECUTE IT
  1607.     DW Q$ELSE
  1608.     DW COMPI-2-$
  1609.  
  1610. COMP2:    DW EXLIT    ;NOT FOUND, MAYBE A LITERAL
  1611.     DW UNDEF
  1612.     DW Q$ELSE
  1613.     DW COMPI-2-$
  1614.  
  1615.     DW $+2
  1616. EXLIT:    LHLD Q$LIT
  1617.     JMP EXEC
  1618.  
  1619.     DW $+2
  1620. Q$COMP:    POP D        ;PTR TO PARAMETER FIELD OF WORD
  1621.     LXI H,-10    ;BACK UP TO PRECEDENCE FIELD
  1622.     DAD D
  1623.     MOV A,M        ;GET 1ST BYTE OF ENTRY
  1624.     ORA A
  1625.     JM NEXT1    ;PRECEDENCE BIT SET, EXECUTE IT
  1626.     LDA Q$STATE    ;PRECEDENCE BIT ZERO, CHECK STATE
  1627.     ORA A
  1628.     JP NEXT1    ;STATE ZERO, EXECUTE IT
  1629.     XCHG        ;STORE ADDR OF PARAMETER FIELD IN COMPLILE BUFFER
  1630.     CALL Q$CCOM
  1631.     JMP Q$NEXT
  1632.  
  1633.     DB 7,'PROMP'    ;PROMPT0
  1634.     IF DEBUG
  1635.     DW ERRCH
  1636.     ENDIF
  1637.     IF NOT DEBUG
  1638.     SLITE
  1639.     ENDIF
  1640.     DW $+2
  1641. PROM0:    LHLD Q$INBLK    ;EXECUTING A FILE Q$
  1642.     INX H
  1643.     MOV A,H
  1644.     ORA L
  1645.     JNZ Q$NEXT    ;YES, NO PROMPT
  1646.     CALL Q$IFCR    ;TYPE A CR IF COLUMN NON-ZERO
  1647.     LDA Q$CHECK    ;TYPE CHECK
  1648.     CALL Q$TTO
  1649.     MVI A,76Q    ;TYPE > 
  1650.     CALL Q$TTO
  1651.     MVI A,40Q    ;TYPE SPACE
  1652.     CALL Q$TTO
  1653.     JMP Q$NEXT    ;RETURN
  1654.  
  1655.     DW Q$COLN
  1656. GO:    DW Q$GO1
  1657. GO1:    DW EXPRO
  1658. GO8:    DW RDLIN
  1659.     DW COMPI
  1660.     DW Q$GO2
  1661.     DW Q$IF
  1662.     DW GO1-2-$
  1663.     DW LIT
  1664.     DW Q$SEMI
  1665.     DW CCOMM
  1666.     DW EXCBUF
  1667.     IF DEBUG
  1668.     DW ERRCH
  1669.     ENDIF
  1670.     DW Q$ELSE
  1671.     DW GO-2-$
  1672.  
  1673.     DW $+2
  1674. EXPRO:    LHLD Q$PROM    ;EXECUTE @ PROMPT
  1675.     JMP EXEC
  1676.  
  1677.     DW $+2
  1678. EXCBUF:    LXI D,CBUF+2    ;EXECUTE COMPILE BUFFER
  1679.     JMP NEXT1
  1680.  
  1681.     DW $+2
  1682. Q$GO1:    MVI A,80H    ;SET STATE TO 80 HEX
  1683.     STA Q$STATE
  1684.     MVI A,60Q    ;SET CHECK TO "0"
  1685.     STA Q$CHECK
  1686.     LXI H,CBUF    ;RESET .C TO START OF COMPILE BUFFER
  1687.     SHLD Q$C
  1688.     LXI H,Q$COLN    ;OUTPUT (:) TO COMPILE BUFFER
  1689.     CALL Q$CCOM
  1690.     JMP Q$NEXT
  1691.  
  1692.     DW $+2
  1693. Q$GO2:    LDA Q$EOC    ;END OF COMMAND Q$
  1694.     ORA A
  1695.     JZ PUSH0    ;NO, RETURN 0
  1696.     LDA Q$CHECK    ;CHECK = "0" Q$
  1697.     CPI 60Q
  1698.     JNZ PUSH0    ;NO, RETURN 0
  1699.     JMP PUSH1    ;YES, RETURN -1
  1700. ;
  1701. ;
  1702.     DB 5,'ENTER'    ;ENTER
  1703.     DW PROM0
  1704.     DW $+2
  1705. ENTER:    LHLD Q$ENT
  1706.     JMP EXEC
  1707.  
  1708.     DB 4,'ENT0',0    ;ENT0
  1709.     DW ENTER
  1710.     DW $+2
  1711. ENT0:    LHLD Q$Q$D    ;ZERO 6 BYTES AT END OF DICTIONARY
  1712.     MVI A,6
  1713. ENT1:    MVI M,0
  1714.     INX H
  1715.     DCR A
  1716.     JNZ ENT1
  1717.  
  1718.     POP B        ;COPY NAME ONTO END OF DICTIONARY
  1719.     MVI A,6        ;6 BYTES
  1720.     STA Q$T1
  1721. ENT2:    LDAX B        ;MOVE NAME AND LENGTH
  1722.     ORA A
  1723.     JZ ENT3        ;FILL WITH NULLS
  1724.     INX B
  1725. ENT3:    CALL Q$BCOM
  1726.     LXI H,Q$T1    ;DONE Q$
  1727.     DCR M
  1728.     JNZ ENT2    ;NO
  1729.  
  1730.             ;LINK NEW ENTRY INTO DICTIONARY
  1731.     LHLD Q$CURR    ;GET PTR TO PREVIOUS ENTRY
  1732.     MOV E,M
  1733.     INX H
  1734.     MOV D,M
  1735.     XCHG
  1736.     CALL Q$COMM    ;STORE IT IN LINK FIELD
  1737.  
  1738.     LHLD Q$Q$D    ;STORE $+2 IN CODE ADDRESS FIELD
  1739.     INX H
  1740.     INX H
  1741.     CALL Q$COMM
  1742.  
  1743.     LHLD Q$Q$D    ;RESET CURRENT TO .
  1744.     XCHG
  1745.     LHLD Q$CURR
  1746.     MOV M,E
  1747.     INX H
  1748.     MOV M,D
  1749.     JMP Q$NEXT    ;RETURN
  1750. ;
  1751. ;
  1752. Q$BRAN:    XCHG        ;PUSH @(DE) ON VOCABULARY STACK
  1753.     MOV E,M
  1754.     INX H
  1755.     MOV D,M
  1756. BRAN1:    LHLD Q$V
  1757.     INX H
  1758.     INX H
  1759.     SHLD Q$V
  1760.     MOV M,E
  1761.     INX H
  1762.     MOV M,D
  1763.     JMP Q$NEXT
  1764.  
  1765.     DB 10,'ASSEM'    ;ASSEMBLER<
  1766.     DW ENT0
  1767.     DW Q$BRAN
  1768. ASSEM:    DW Q$ASSE
  1769.  
  1770.     DB 6,'STOIC'    ;STOIC<
  1771.     DW ASSEM
  1772.     DW Q$BRAN
  1773. STOIC:    DW Q$STOI
  1774.  
  1775.     DB 2,'<L',0,0,0    ;<L
  1776.     DW STOIC
  1777.     DW $+2
  1778. LPUSH:    POP H
  1779.     CALL Q$LPUSH
  1780.     JMP Q$NEXT
  1781.  
  1782.     DB 2,'L>',0,0,0    ;L>
  1783.     DW LPUSH
  1784.     DW $+2
  1785. LPOP:    CALL Q$LPOP
  1786.     JMP Q$Q$PUSH
  1787.  
  1788.     DB 4,'LOAD',0    ;LOAD
  1789.     DW LPOP
  1790.     DW $+2
  1791. LOAD:    LHLD Q$INBLK
  1792.     CALL Q$LPUSH
  1793.     LHLD Q$INBYT
  1794.     CALL Q$LPUSH
  1795.     POP H
  1796.     SHLD Q$INBLK
  1797.     LXI H,0
  1798.     SHLD Q$INBYT
  1799.     JMP Q$NEXT
  1800.  
  1801.     DB 2,';F',0,0,0    ;;F
  1802.     DW LOAD
  1803.     DW $+2
  1804. Q$SCLF:    CALL Q$LPOP
  1805.     SHLD Q$INBYT
  1806.     CALL Q$LPOP
  1807.     SHLD Q$INBLK
  1808.     JMP Q$NEXT
  1809.  
  1810. ;POP A NUMBER OFF THE LOOP STACK
  1811. ;
  1812. ;    CALL Q$LPOP
  1813. ;    HL CONTAINS NUMBER
  1814.  
  1815. Q$LPOP:    LHLD Q$Q$L    ;LOOP STACK PTR
  1816.     MOV E,M        ;GET TOP OR STACK INTO DE
  1817.     INX H
  1818.     MOV D,M
  1819.     DCX H
  1820.     DCX H        ;DECREMENT LOOP STACK PTR BY 2
  1821.     DCX H
  1822.     SHLD Q$Q$L
  1823.     XCHG        ;MOVE RESULT TO HL
  1824.     RET        ;RETURN
  1825.  
  1826. ;PUSH A NUMBER ON THE LOOP STACK
  1827. ;
  1828. ;    HL CONTAINS NUMBER
  1829. ;    CALL Q$LPUSH
  1830.  
  1831. Q$LPUSH:    XCHG        ;MOVE NUMBER TO DE
  1832.     LHLD Q$Q$L    ;INCREMENT LOOP STACK PTR BY 2
  1833.     INX H
  1834.     INX H
  1835.     SHLD Q$Q$L
  1836.     MOV M,E        ;STORE NUMBER ON END OF RETURN STACK
  1837.     INX H
  1838.     MOV M,D
  1839.     RET        ;RETURN
  1840.  
  1841.     DB 11,'DEFIN'    ;DEFINTIONS
  1842.     DW Q$SCLF
  1843.     DW $+2
  1844. DEFIN:    LHLD Q$V
  1845.     MOV E,M
  1846.     INX H
  1847.     MOV D,M
  1848.     XCHG
  1849.     SHLD Q$CURR
  1850.     JMP Q$NEXT
  1851.  
  1852.     DB 1,'>',0,0,0,0    ;>
  1853.     DW DEFIN
  1854.     DW $+2
  1855. REVER:    LHLD Q$V
  1856.     DCX H
  1857.     DCX H
  1858.     SHLD Q$V
  1859.     JMP Q$NEXT
  1860.  
  1861.     DB 201Q,'^',0,0,0,0    ;^
  1862.     DW REVER
  1863.     DW $+2
  1864. UPARR:    SUB A
  1865.     STA Q$EOC
  1866.     JMP Q$NEXT
  1867.  
  1868.     DB 201Q,'%',0,0,0,0    ;%
  1869.     DW UPARR
  1870.     DW $+2
  1871. PERC:    MVI A,0FFH
  1872.     STA Q$EOL
  1873.     JMP Q$NEXT
  1874. ;
  1875. ;
  1876.     DB 201Q,':',0,0,0,0    ;:
  1877.     DW PERC
  1878.     DW $+2
  1879. COLON:    LDA Q$CHECK
  1880.     CPI 60Q
  1881.     JNZ CHERR
  1882.     INR A
  1883.     STA Q$CHECK
  1884.     LXI H,ENTER
  1885.     CALL Q$CCOM
  1886.     LXI H,COLN1
  1887.     CALL Q$CCOM
  1888.     LHLD Q$C
  1889.     PUSH H
  1890.     LXI H,0
  1891.     CALL Q$CCOM
  1892.     JMP Q$NEXT
  1893.  
  1894. CHERR:    LXI H,CHERM
  1895.     JMP ERROR
  1896. CHERM:    DB 12,'SYNTAX ERROR'
  1897.  
  1898. Q$COLN:    LHLD Q$I        ;(;)
  1899.     XCHG
  1900.     DCX H        ;SET .I TO W-2
  1901.     DCX H
  1902.     SHLD Q$I
  1903.     LHLD Q$R        ;INCREMENT RETURN STACK PTR BY 2
  1904.     INX H
  1905.     INX H
  1906.     SHLD Q$R
  1907.     MOV M,E        ;STORE .I ON END OF RETURN STACK
  1908.     INX H
  1909.     MOV M,D
  1910.     JMP Q$NEXT
  1911.  
  1912.     DW $+2
  1913. COLN1:    LHLD Q$I
  1914.     INX H
  1915.     INX H
  1916.     MOV E,M
  1917.     INX H
  1918.     MOV D,M
  1919.     INX H
  1920. COLN2:    PUSH H
  1921.     PUSH D
  1922.     MOV A,M
  1923.     CALL Q$BCOM
  1924.     POP D
  1925.     POP H
  1926.     INX H
  1927.     DCX D
  1928.     MOV A,D
  1929.     ORA E
  1930.     JNZ COLN2
  1931.     DCX H
  1932.     DCX H
  1933.     SHLD Q$I
  1934.     LHLD Q$CURR
  1935.     MOV E,M
  1936.     INX H
  1937.     MOV D,M
  1938.     DCX D
  1939.     DCX D
  1940.     LXI H,Q$COLN
  1941.     XCHG
  1942.     MOV M,E
  1943.     INX H
  1944.     MOV M,D
  1945.     JMP Q$NEXT
  1946.  
  1947.     DB 205Q,'CODE<'        ;CODE<
  1948.     DW COLON
  1949.     DW Q$COLN
  1950. CODE:    DW LIT
  1951.     DW ENTER
  1952.     DW CCOMM
  1953.     DW ASSEM
  1954.     DW Q$SEMI
  1955.  
  1956.     DB 201Q,';',0,0,0,0    ;;
  1957.     DW CODE
  1958.     DW $+2
  1959. SCOL:    CALL Q$SCOL    ;TERMINATE COLON DEFINITION
  1960.     LXI H,Q$SEMI    ;OUTPUT (;) TO COMPILE BUFFER
  1961.     CALL Q$CCOM
  1962.     JMP Q$NEXT
  1963.  
  1964.     DB 206Q,';CODE'        ;;CODE<
  1965.     DW SCOL
  1966.     DW $+2
  1967. SCLCD:    CALL Q$SCOL    ;TERMINATE COLON DEFINITION
  1968.     LXI H,Q$SCOD    ;OUTPUT (;CODE) TO COMPILE BUFFER
  1969.     CALL Q$CCOM
  1970.     LXI D,Q$ASSE    ;ASSEMBLER<
  1971.     JMP BRAN1
  1972.  
  1973. Q$SCOL:    LDA Q$CHECK    ;DECREMENT CHECK
  1974.     DCR A
  1975.     CPI 60Q
  1976.     JNZ CHERR    ;ERROR IF NOT ZERO
  1977.     STA Q$CHECK
  1978.     POP H        ;OLD C.
  1979.     XTHL
  1980.     PUSH H
  1981.     CALL Q$MHL    ;COMPUTE DIFFERENCE
  1982.     XCHG
  1983.     LHLD Q$C        ;C.
  1984.     DAD D
  1985.     XCHG
  1986.     POP H        ;OLD C.
  1987.     MOV M,E        ;STORE DIFFERENCE AT OLD C.
  1988.     INX H
  1989.     MOV M,D
  1990.     RET
  1991.  
  1992.     DB 8,'CONST'    ;CONSTANT
  1993.     DW SCLCD
  1994.     DW Q$COLN
  1995. CONST:    DW ENTER
  1996.     DW COMMA
  1997.     DW Q$SCOD
  1998. Q$CONS:    XCHG        ;(CONSTANT)
  1999.     JMP ATPUS
  2000. ;
  2001. ;
  2002.     DB 4,'PUSH',0        ;PUSH
  2003.     DW 0
  2004.     DW Q$CONS
  2005. PUSHQ$:    DW Q$Q$PUSH
  2006.  
  2007.     DB 4,'NEXT',0        ;NEXT
  2008.     DW PUSHQ$
  2009.     DW Q$CONS
  2010. NEXTQ$:    DW Q$NEXT
  2011.  
  2012.     DB 5,'DPUSH'        ;DPUSH
  2013.     DW NEXTQ$
  2014.     DW Q$CONS
  2015. DPSHQ$:    DW Q$DPUSH
  2016.  
  2017.     DB 5,'@PUSH'        ;@PUSH
  2018.     DW DPSHQ$
  2019.     DW Q$CONS
  2020. ATPSQ$:    DW ATPUS
  2021.  
  2022.     DB 5,'PUSHD'        ;PUSHD
  2023.     DW ATPSQ$
  2024.     DW Q$CONS
  2025. PUSDQ$:    DW PUSHD
  2026.  
  2027.     DB 5,'0PUSH'        ;0PUSH
  2028.     DW PUSDQ$
  2029.     DW Q$CONS
  2030. PUS0Q$:    DW PUSH0
  2031.  
  2032.     DB 6,'-1PUS'        ;-1PUSH
  2033.     DW PUS0Q$
  2034.     DW Q$CONS
  2035. PUS1Q$:    DW PUSH1
  2036.  
  2037.     DB 3,'MUL',0,0        ;MUL
  2038.     DW PUS1Q$
  2039.     DW Q$CONS
  2040. MULQ$:    DW Q$MUL
  2041.  
  2042.     DB 3,'-HL',0,0        ;-HL
  2043.     DW MULQ$
  2044.     DW Q$CONS
  2045. MHLQ$:    DW Q$MHL
  2046.  
  2047.     DB 5,'(MSG)'        ;(MSG)
  2048.     DW MHLQ$
  2049.     DW Q$CONS
  2050. MSGQ$:    DW Q$MSG
  2051.  
  2052.     DB 3,'(,)',0,0        ;(,)
  2053.     DW MSGQ$
  2054.     DW Q$CONS
  2055. COMMQ$:    DW Q$COMM
  2056.  
  2057.     DB 4,'(B,)',0        ;(B,)
  2058.     DW COMMQ$
  2059.     DW Q$CONS
  2060. BCOMQ$:    DW Q$BCOM
  2061.  
  2062.     DB 8,'(BRAN'        ;(BRANCH)
  2063.     DW BCOMQ$
  2064.     DW Q$CONS
  2065. BRANQ$:    DW Q$BRAN
  2066.  
  2067.     DB 5,'ERROR'        ;ERROR
  2068.     DW BRANQ$
  2069.     DW Q$CONS
  2070. ERRQ$:    DW ERROR
  2071.  
  2072.     DB 5,'(TTI)'        ;(TTI)
  2073.     DW ERRQ$
  2074.     DW Q$CONS
  2075. TTIQ$:    DW TTYIN
  2076.  
  2077.     DB 5,'(TTO)'        ;(TTO)
  2078.     DW TTIQ$
  2079.     DW Q$CONS
  2080. TTOQ$:    DW Q$TTO
  2081.  
  2082.     DB 6,'(READ'        ;(READ)
  2083.     DW TTOQ$
  2084.     DW Q$CONS
  2085. READQ$:    DW Q$RDERC
  2086.  
  2087.     DB 7,'(WRIT'        ;(WRITE)
  2088.     DW READQ$
  2089.     DW Q$CONS
  2090. WRITQ$:    DW Q$WRERC
  2091.  
  2092.     DB 8,'(RBLO'        ;(RBLOCK)
  2093.     DW WRITQ$
  2094.     DW Q$CONS
  2095. RBLKQ$:    DW RBLK
  2096.  
  2097.     DB 8,'(WBLO'        ;(WBLOCK)
  2098.     DW RBLKQ$
  2099.     DW Q$CONS
  2100. WBLKQ$:    DW WBLK
  2101.  
  2102.     DB 2,'T1',0,0,0        ;T1
  2103.     DW WBLKQ$
  2104.     DW Q$CONS
  2105. T1Q$:    DW Q$T1
  2106.  
  2107. ;8080 INSTRUCTION CLASSES
  2108.     DB 2,'R0',0,0,0        ;R0
  2109.     DW T1Q$
  2110.     DW Q$COLN
  2111. XR0:    DW CONST
  2112.     DW Q$SCOD
  2113.     LDAX D
  2114.     CALL Q$BCOM
  2115.     JMP Q$NEXT
  2116.  
  2117.     DB 2,'R1',0,0,0        ;R1
  2118.     DW XR0
  2119.     DW Q$COLN
  2120. R1:    DW CONST
  2121.     DW Q$SCOD
  2122.     CALL SH3
  2123. R11:    CALL Q$BCOM
  2124.     JMP Q$NEXT
  2125.  
  2126.     DB 2,'R2',0,0,0        ;R2
  2127.     DW R1
  2128.     DW Q$COLN
  2129. R2:    DW CONST
  2130.     DW Q$SCOD
  2131.     CALL SH3
  2132. R21:    POP H
  2133.     ADD L
  2134.     JMP R11
  2135.  
  2136.     DB 2,'R3',0,0,0        ;R3
  2137.     DW R2
  2138.     DW Q$COLN
  2139. R3:    DW CONST
  2140.     DW Q$SCOD
  2141.     LDAX D
  2142.     JMP R21
  2143.  
  2144.     DB 2,'R4',0,0,0        ;R4
  2145.     DW R3
  2146.     DW Q$COLN
  2147. R4:    DW CONST
  2148.     DW Q$SCOD
  2149.     LDAX D
  2150. R41:    CALL Q$BCOM
  2151.     POP H
  2152.     MOV A,L
  2153.     CALL Q$BCOM
  2154.     JMP Q$NEXT
  2155.  
  2156.     DB 2,'R5',0,0,0        ;R5
  2157.     DW R4
  2158.     DW Q$COLN
  2159. R5:    DW CONST
  2160.     DW Q$SCOD
  2161.     CALL SH3
  2162.     JMP R41
  2163.  
  2164.     DB 2,'R6',0,0,0        ;R6
  2165.     DW R5
  2166.     DW Q$COLN
  2167. R6:    DW CONST
  2168.     DW Q$SCOD
  2169.     CALL SH3
  2170. R61:    CALL Q$BCOM
  2171.     POP H
  2172. R62:    CALL Q$COMM
  2173.     JMP Q$NEXT
  2174.  
  2175.     DB 2,'R7',0,0,0        ;R7
  2176.     DW R6
  2177.     DW Q$COLN
  2178. R7:    DW CONST
  2179.     DW Q$SCOD
  2180.     LDAX D
  2181.     JMP R61
  2182.  
  2183.     DB 2,'R8',0,0,0        ;R8
  2184.     DW R7
  2185.     DW Q$COLN
  2186. R8:    DW CONST
  2187.     DW Q$SCOD
  2188.     LDAX D
  2189.     CALL Q$BCOM
  2190.     LHLD Q$Q$D
  2191.     PUSH H
  2192.     LXI H,0
  2193.     JMP R62
  2194.  
  2195. ;SHIFT TOP OF STACK 3 LEFT AND ADD BYTE ADDRESSED BY DE
  2196. ;LEAVING RESULT IN A
  2197.  
  2198. SH3:    POP H
  2199.     XTHL
  2200.     DAD H
  2201.     DAD H
  2202.     DAD H
  2203.     LDAX D
  2204.     ADD L
  2205.     RET
  2206.  
  2207. ;
  2208. ;UNIT NUMBER
  2209. Q$UNIT:    DW 0
  2210.  
  2211. ;BUFFER CONTROL TABLES
  2212. BCT1:    DW -1        ;BLOCK #
  2213.     DW BUF1        ;BUFFER ADDR
  2214.     DW BCT2        ;LINK
  2215.     DW 0        ;MODIFIED FLAG
  2216.  
  2217. BCT2:    DW -1
  2218.     DW BUF2
  2219.     DW 0
  2220.     DW 0
  2221.  
  2222. ;I/O BUFFERS
  2223. BUF1:    DS BSIZE
  2224. BUF2:    DS BSIZE
  2225.  
  2226. ;BUFFER HANDLER VARIABLES
  2227. NEWEST:    DW BCT1        ;HEAD OF BCT LIST
  2228. PREV:    DW 0        ;BUFFER STRATEGY TEMPORARIES
  2229. BUFP:    DW 0
  2230. BLKN:    DW 0
  2231. FLAG:    DB 0
  2232.  
  2233. ;START OF USER MEMORY
  2234.  
  2235. ;VARIABLES
  2236. ;
  2237. ;***************
  2238. ;*** WARNING ***
  2239. ;***************
  2240. ;
  2241. ;DO NOT ADD, DELETE, OR REARRANGE THE FOLLOWING
  2242. ;VARIABLES WITHOUT MAKING CORRESPONDING CHANGES
  2243. ;TO THE BASIC DEFINITIONS FILE WHICH DEFINES THE
  2244. ;ADDRESSES OF THESE VARIABLES.
  2245.  
  2246. ;BYTE VARIABLES
  2247. Q$STATE:    DB 0        ;STATE
  2248. Q$CHECK:    DB 0        ;CHECK
  2249. Q$COLU:    DB 0        ;COLUMN
  2250.  
  2251. ;WORD VARIABLES
  2252. Q$I:    DW 0        ;.I
  2253. Q$R:    DW 0        ;.R
  2254. Q$Q$L:    DW 0        ;.L
  2255. Q$V:    DW VSTACK+2    ;.V
  2256. Q$Q$D:    DW LASTW    ;.D
  2257. Q$C:    DW 0        ;.C
  2258. Q$CURR:    DW Q$STOI    ;CURRENT
  2259. Q$RADIX:    DW 8        ;RADIX
  2260. Q$PROM:    DW PROM0    ;PROMPT
  2261. Q$ERRM:    DW ERRM0    ;ERRMSG
  2262. Q$ENT:    DW ENT0        ;ENT
  2263. Q$MEMO:    DW 0        ;MEMORY
  2264. Q$LIT:    DW LITER    ;LIT
  2265. Q$TYI:    DW Q$TTYI    ;(TTYIN)
  2266. Q$TYO:    DW Q$TTYO    ;(TTYOU)
  2267. Q$ABORT:    DW Q$AB        ;(ABORT)
  2268.  
  2269. ;INTERNAL VARIABLES
  2270. Q$EOC:    DB 0        ;EOC
  2271. Q$EOL:    DB 0        ;EOL
  2272. Q$ASSE:    DW R8        ;ASSEMBLER<
  2273. Q$STOI:    DW CONST    ;STOIC<
  2274. Q$INP:    DW 0        ;INP
  2275. Q$INBYT:    DW 0        ;INBYTE
  2276. Q$INBLK:    DW 0        ;INBLK
  2277.  
  2278. Q$T1:    DW 0        ;TEMPORARIES
  2279. Q$T2:    DW 0
  2280. Q$T3:    DW 0
  2281. Q$T4:    DW 0
  2282. Q$T5:    DW 0
  2283. Q$T6:    DW 0
  2284. Q$T7:    DW 0
  2285. Q$T8:    DW 0
  2286. Q$T9:    DW 0
  2287. Q$T10:    DW 0
  2288.  
  2289. ;PARAMETER STACK
  2290. SSTKE:    DS SSIZE
  2291. SSTACK:    DS 8        ;PROTECTION AGAINST STACK UNDERFLOW
  2292.  
  2293. ;VOCABULARY STACK
  2294. VSTACK:    DW 0
  2295.     DW Q$STOI
  2296.     DS VSIZE
  2297.  
  2298. ;LOOP STACK
  2299. LSTACK:    DS LSIZE
  2300.  
  2301. ;RETURN STACK
  2302. RSTACK:    DS RSIZE
  2303.  
  2304. ;COMPILE BUFFER
  2305. CBUF:    DS CSIZE
  2306.  
  2307. ;KEYBOARD BUFFER
  2308. KBUF:    DS KSIZE
  2309.  
  2310. ;END OF KERNEL
  2311. LASTW    EQU    $
  2312.     IF NOT CPM
  2313. ;
  2314. ;INITIALIZATION CODE, OVERWRITTER BY DICTIONARY
  2315. ;SIZE MEMORY, SET Q$MEMO, JMP TO ABORT
  2316. SIZE:    LXI H,0C000H    ;FIRST DEVICE ADDRESS
  2317.     MVI A,55H    ;ALTERNATING 1'S AND 0'S
  2318. SIZE1:    DCX H        ;DECREMENT TO NEXT LOC
  2319.     MOV M,A        ;STORE BYTE IN MEMORY
  2320.     CMP M        ;CAN READ IT BACK Q$
  2321.     JNZ SIZE1    ;NO, CONTINUE
  2322.     INX H        ;BACK UP
  2323.     SHLD Q$MEMO    ;SET MEMORY LIMIT
  2324.     JMP ABORT    ;START UP STOIC
  2325. ;
  2326.     ENDIF
  2327. ;
  2328. ;
  2329. ;SET UP START ADDRESS
  2330. ;
  2331.     IF NOT CPM
  2332. START    SET    SIZE
  2333.     ENDIF
  2334. ;
  2335.     IF CPM
  2336. START    SET    TPA
  2337.     ENDIF
  2338. ;
  2339. ;
  2340.     END START
  2341.  
  2342.  
  2343. ***EOF***
  2344.