home *** CD-ROM | disk | FTP | other *** search
/ Hall of Fame / HallofFameCDROM.cdr / prog1 / 4th_86.lzh / 7NXTRA3.4TH < prev    next >
Text File  |  1989-05-08  |  11KB  |  321 lines
  1. ( 1st. February 1989 - 4th_86 version 3.0 - MFB )
  2.  
  3. off printload
  4. on redefine
  5.  
  6. ( This file contains various odd bits of code which have been displaced
  7.   from other source files 
  8.  
  9. The section marked ** is no longer used -- GLOAD replaces CLOAD -- but
  10. it has been left here in case the previous format MASM files with 
  11. embedded dictionary entries are preferred. To use it - uncoment it and
  12. recompile. NOTE however that the word $!+ has been commented out of
  13. 7BASIC3 as it serves no purpose other than to assist definition of LXWRD
  14. and will have to be loaded separately if you want to re-implement CLOAD )
  15.  
  16.  
  17. ( *** following three words transferred here from original 
  18.                              7DOUBLE3 which is now MASM code ****)
  19.  
  20. : ,AND swap 4 pick and 3 poke and ;
  21. ( *******************)
  22. : ,OR  swap 4 pick or 3 poke or ;
  23. ( *******************)
  24. : ,XOR swap 4 pick xor 3 poke xor ;
  25.  
  26.  
  27. ( *******************)
  28. : FLOAD WORD dup string $! LOAD ;
  29.  
  30. ( *******************)
  31. 2 block savehead   
  32. 2 block saveihead   
  33. 2 block savesysl   
  34. 2 block savelum
  35. DATA[ BYTE " 4th_86.com" ] savesysn
  36.  
  37. ( *******************)
  38. : saveinit
  39. LAST @ B@ IF
  40.   LAST @ HEAD @ TOPDICT 3 + 3 PICK - ( compute size of diction)
  41.   ( TOS: source, dest, size )
  42.   HEAD @ ' SYSLAST 3 + dup@ savesysl ! ! ( SYSLAST points to new dict segment)
  43.   OVER OVER + DUP HEAD dup@ savehead ! !
  44.                   ' INITHEAD 3 + dup@ saveihead ! ! ( HEAD and INITHEAD fixed)
  45.   MOVE ( dictionary attached )
  46. then 
  47. LUM @ ' INITLUM 3 + dup@ savelum ! ! ( INITLUM  fixed ) ;
  48.  
  49. ( *******************)
  50. : dosave dup 2 SYSOPEN HEAD @ 100H - 100H 3 PICK SYSWRITE SYSCLOSE
  51. crlf " system saved as  " ." ." crlf
  52. savehead @ head !           saveihead @ ' inithead 3 + !   
  53. savesysl @ ' syslast 3 + !  savelum  @ ' initlum 3 + !      ;
  54.  
  55. ( *******************)
  56. : fsave saveinit word dosave ;
  57.  
  58. ( *******************)
  59. : savesys saveinit savesysn string $! string dosave ;
  60.  
  61. ( *******************)
  62. : quote ; ( dummy stub for 'LINKing' to if quote included ) 
  63.  
  64. : bye norm quote q-u-it ; ( normal exit method )
  65.  
  66. ( *******************)
  67. : ILOAD WORD GIMAGE ;
  68.  
  69. ( *******************)
  70. : ISAVE WORD dup PIMAGE crlf " image saved as  " ." ." ;
  71.  
  72. ( *******************)
  73. : RECURSE LAST @ DUP B@ + 2 + @ HEAD! ; IMMEDIATE
  74.  
  75. ( ********** -------- following no longer used -------- *********** 
  76. **                          VVVVVVV
  77. **
  78. ** DATA[ WORD 0 ] FCBADD                ( to avoid keeping it on stack)
  79. ** DATA[ BYTE " endfile" ] EOFSTRG      ( for comparison with input stream)
  80. ** DATA[ BYTE " endproc" ] NTRYSTRG     ( for comparison with input stream)
  81. ** DATA[ WORD 0 ] SLAST             ( simulate last while defining)
  82. ** 10 BLOCK IBUFF                 ( buffer for dictionary string)
  83. ** DATA[ WORD 0 ] CTFLAG
  84. ** DATA[ WORD 0 ] CSFLAG
  85. **
  86. ** ( *******************)
  87. ** : FIND[ ( load bytes till 'e' found -- returns only nok or ok flag)
  88. **     FCBADD @ 
  89. **        REPEAT DUP SYSRBYTE 
  90. **           0= if 0FFH ( nok flag) return then ( sysrbyte flag dropped)
  91. **           DUP ( BYTE on TOS) "e" = 0= 
  92. **        WHILE HEADB! ENDWHILE 
  93. **             SWAP DROP headb! ( save it whatever) 0 ( ok flag) ;
  94. ** 
  95. ** ( *******************)
  96. ** : RBYTE ( read one byte from file)
  97. **      FCBADD @ SYSRBYTE DROP ; 
  98. ** 
  99. ** ( *******************)
  100. ** : LXSTRG  ( read 7 bytes to test for 'endproc' and 'endfile')
  101. **      6 0 DO RBYTE HEADB! LOOP ;
  102. ** 
  103. ** ( *******************)
  104. ** : FBUFF ( read label from input file and store in IBUFF with count)
  105. **      IBUFF SLAST ! ( use SLAST as pointer into IBUFF )
  106. **      0 1- BEGIN 1+ ( count) 
  107. **           SLAST DUP@ 1+ SWAP ! ( update SLAST)
  108. **                RBYTE ctflag @ if dup headb! 
  109. **                                   then DUP SLAST @ B! 20H = END 
  110. **           IBUFF B! ( count) ;
  111. ** 
  112. ** 
  113. ** ( *******************)
  114. ** : LXWRD  ( read next word from file and store at LAST)
  115. **     FBUFF 
  116. **      IBUFF B@ 1- DUP 4 + LAST @ SWAP - SLAST ! 
  117. **          SLAST @ DUP IBUFF SWAP $!+ + 0 SWAP 1+ drop drop ;
  118. ** 
  119. ** ( *******************)
  120. ** CODE STEST ( string test -- scan HL and DE strings for match)
  121. **      ' PSHSI# CALL, C 8 MVI, ( character count)
  122. **            H POP, D POP, ( pointers to strings)
  123. **       BEGIN D LDAX, C DCR,                  M CMP, 
  124. **             PSW PUSH, H INX, D INX, PSW POP,     ENDNZ ( mismatch)
  125. **           H 0 MVI, L C MOV, ( will be zero only if whole string matches)
  126. **                H PUSH, ' POPSI# CALL, H POP, 
  127. **            ;PUSH
  128. ** 
  129. ** ( *******************)
  130. ** : DOLOAD ( kept separate so that RETURN will drop into CLOAD correctly)
  131. **       BEGIN 
  132. **             FIND[ ( returns only ok or nok flag)
  133. **                   0FFH = IF DROP DROP ( pointers for STEST) 
  134. **                            RETURN ( 'e' not found - file exhausted)
  135. **                          THEN 
  136. **                            ( GETLOC ) HEAD @
  137. ** 
  138. **             LXSTRG   ( get NTY string for testing)
  139. **             1- ( pointer for string test AND for jmp THREAD)           
  140. **             DUP ( for STEST)
  141. **                NTRYSTRG 1+ ( ignore length byte)
  142. **                SWAP STEST ( do test) 
  143. **                       ( aarghh! => will miss next 'e' if within 7 bytes )
  144. **                0= IF LXWRD 
  145. **                ( getloc) head @ swap head ! 
  146. ** 
  147. **                   0E9H HEADB!  
  148. **                ' THREAD HEAD @ - 2 - CROSS @ IF BASE @ + THEN
  149. **                               HEAD! ( JMP THREAD)
  150. **                   head ! ( to value after LXWRD)
  151. **         SLAST @ LAST ! 
  152. **                   head @ CROSS @ IF BASE @ - THEN
  153. **                          SLAST @ DUPB@ + 2 + !   ( value of code addr)
  154. **                                                 ( return )
  155. **         ( else drop)
  156. **         THEN 
  157. **         
  158. **             ( no LXSTRG -- already in place -- also 1- already done)
  159. **             DUP ( for STEST)
  160. **                EOFSTRG 1+ ( ignore length byte)
  161. **                SWAP STEST ( do test)
  162. **                0= ( loop if 'endfile' string not found)
  163. **       END         ( 'endfile' string found)
  164. **        HEAD ! ( restore HEAD to getloc value less one ) drop  ;
  165. ** 
  166. ** ( *******************)
  167. ** : CsLOAD ( load COM file)
  168. **           GETLOC  csflag @ if
  169. **      10h + fff0h and dup 
  170. **                 cross @ if base @ + then
  171. **                          head ! then 
  172. **      ( .H "  ===> start of code" ." crlf) drop
  173. **      ( 0 DEFINE ) ( last @ dup word swap $! dup 0 swap b! head @ swap !)
  174. **      word ( LAST @ ) 1 SYSOPEN FCBADD ! ( open file and store FCBADD)
  175. **     DOLOAD   FCBADD @ SYSCLOSE
  176. **             0E9H HEADB! ' THREAD CROSS @ IF BASE @ + THEN
  177. **               HEAD @ - 2 - HEAD! depth kill
  178. **           ( GETLOC .H "  ===> end of code" ." crlf  ) ;
  179. ** 
  180. ** : ctload 0 ctflag ! 0 csflag ! csload ; 
  181. **                               ( trim off redundant labels in code area)
  182. **                   ( involves extra work in ASM file)
  183. ** 
  184. ** : cload  1 ctflag ! 0 csflag ! csload ; 
  185. **                               ( include redundant labels in code area)
  186. **                   ( makes life easy with ASM file)
  187. ** 
  188. ** : c0load  1 ctflag ! 1 csflag ! csload ; 
  189. **                               ( as for cload, but loads at xxx0 )
  190. ** 
  191. **
  192. **                          ^^^^^^
  193. **  ********** -------- above no longer used -------- ************** 
  194. ** 
  195. **                   ---------- replaced by ---------------
  196. **                                 VVVVV                     )
  197.  
  198. data[ WORD 0 ] fcbaddx
  199. data[ WORD 0 ] headad
  200. data[ WORD 0 ] dictad
  201. data[ BYTE " ndfile " ] eofstr
  202. data[ BYTE " ndproc " ] ntrystr
  203. data[ BYTE " xxxxxx " ] strgbuf
  204. data[ WORD  0 ] strptr
  205. data[ WORD 0 ] slastx
  206. data[ BYTE 0 ] eoflg
  207. data[ WORD 0 ] dptr
  208.  
  209. ( ******************* 
  210.  same as headb! but at strgbuf
  211.   *********************** )
  212. : str! strptr @ 1+ strptr ! strptr @ B! ;
  213.  
  214. ( ******************* 
  215.  read byte from file
  216.   *********************** )
  217. : rbyter fcbaddx @ sysrbyte 0= eoflg B! ;
  218.  
  219. ( ******************* 
  220.  read next 6 characters into strgbuf
  221.  *********************** )
  222. : lxstrgg strgbuf strptr ! 6 0 do rbyter str! loop ;
  223.  
  224. ( ******************* 
  225.  do file load at HEAD until endproc
  226.   *********************** )
  227. : dload fcbaddx @ 
  228.        repeat dup sysrbyte dup 0=  
  229.               eoflg B! swap dup "e" = if 3 kill return then 
  230.              swap 0= 0= while 
  231.                  ( head @ dup 1+ head ! ! ) headb! endwhile drop ;
  232.  
  233. ( ******************* 
  234.  do dictionary entry load after endproc
  235.   *********************** )
  236. : d2load fcbaddx @ 
  237.        repeat dup sysrbyte dup 0= 
  238.                 eoflg B! swap dup "e" = if 3 kill return then
  239.             swap 0= 0= while 
  240.                  dictad @ dup 1+ dictad ! ! endwhile drop ;
  241.  
  242. ( ******************* 
  243.  add value at headad to CFA addresses
  244.   *********************** )
  245. : relocate dptr @ 
  246.              begin dup B@ ( length byte)
  247.       + 2 + ( at PFA) dup 2+ dptr ! dup @ ( pfa contents ) 
  248.               100h - ( code offset) ( headad )
  249.          headad @ cross @ if base @ - then + swap !
  250.         dptr @ dup last @ swap -  0=  end slastx @ last ! 
  251.                                                          ( drop ) ;
  252.  
  253. : updd "e" ( head @ dup 1+ head ! ! ) headb! 
  254.             strgbuf 1+ head @ 7 move 7 head +! ; 
  255.  
  256. : upd2 "e" dictad @ dup 1+ dictad ! ! 
  257.             strgbuf 1+ dictad @ 7 move 7 dictad +! ; 
  258.  
  259. ( ******************* 
  260.  equivalent to csload
  261.   *********************** )
  262. : gsload word dup string $! 1 sysopen fcbaddx ! 
  263.  
  264.        begin dload lxstrgg 
  265.          ntrystr 1+  strgbuf 1+ 5 strcmp 0= dup if updd then 0= end
  266.  
  267.         head @ dictad ! 
  268.     begin d2load lxstrgg  ( then )
  269.           eofstr  1+  strgbuf 1+ 5 strcmp 0= dup if ( return )
  270.                    ( then ) upd2  then ( eoflg b@ ) 0= end ;
  271.  
  272. ( ******************* 
  273. move dictionary
  274.   *********************** )
  275. : dmove  dictad @ head @ - dup last @ swap - head @  
  276.    swap dup slastx ! dup dptr ! rot move ;
  277.  
  278. ( ******************* 
  279. close files and go round the 
  280.   edit - compile cycle again
  281.   *********************** )
  282. ( : panic fcbaddx @ sysclose redit ; )
  283.  
  284. ( ******************* 
  285.  test stub
  286.   *********************** )
  287. : gdoit gsload dmove relocate
  288.        fcbaddx @ sysclose  ; ( crlf 
  289.   headad @ 8dm drop crlf head @ 8dm drop crlf dictad @ .h ; )
  290.      
  291. ( ******************* 
  292. replaces cload
  293.   *********************** )
  294. : gload head @ headad ! gdoit drop ;
  295.  
  296. ( ******************* 
  297. replaces c0load
  298.   *********************** )
  299. : g0load getloc 10h + fff0h and cross @ if base @ + then
  300.                         dup head ! headad ! gdoit drop ;
  301.  
  302.  
  303. 2 block olkad
  304. 2 block olkad1
  305. 2 block olkad2
  306.  
  307. ( ******************* 
  308. link now works in cross mode as well
  309.   *********************** )
  310. : link gtdfa cross @ if base @ + then
  311.        ( from) dup olkad ! dup dup@ olkad1 ! 2+ @ olkad2 !
  312.         gtdfa cross @ if base @ + then
  313.        ( to) over - 3 - swap dup e9h swap b! 1+ ! ;
  314.  
  315. ( ******************* 
  316. but can't see why we'd want to 
  317.    unlink whilst in cross mode
  318.   *********************** )
  319. : unlink olkad1 @ olkad @ ! olkad2 @ olkad @ 2+ ! ;
  320.  
  321.