home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FFA.ZIP / KERNEL4.SEQ < prev    next >
Encoding:
Text File  |  1988-01-06  |  10.2 KB  |  307 lines
  1. \ KERNEL4.SEQ   Last part of the kernel file, finishes up the compile.
  2.  
  3. \ Link this file into the FILELIST chain.
  4.  
  5. FILES DEFINITIONS
  6.  
  7. VARIABLE KERNEL4.SEQ
  8.  
  9. FORTH DEFINITIONS   META IN-META
  10.  
  11. VARIABLE #USER
  12.  
  13. VOCABULARY USER   USER DEFINITIONS
  14.  
  15. : ALLOT         ( n -- ) #USER +!   ;
  16.  
  17. ' CREATE        ( avoid recursion: leave address for , in CREATE )
  18.  
  19. : CREATE        ( -- ) [ , ]     #USER @ ,   ;USES  DOUSER-VARIABLE ,-X
  20.  
  21. : VARIABLE      ( -- ) CREATE   2 ALLOT   ;
  22.  
  23. : DEFER         ( -- ) VARIABLE   ;USES   DOUSER-DEFER  ,-X
  24.  
  25. FORTH DEFINITIONS   META IN-META
  26.  
  27. : >IS           ( cfa -- data-address )
  28.                 DUP 1+ @ OVER >BODY +
  29.                 DUP [  [ASSEMBLER] DOUSER-VARIABLE META ] LITERAL = SWAP
  30.                 DUP [  [ASSEMBLER] DOUSER-DEFER    META ] LITERAL = SWAP
  31.                 DROP   OR IF   >BODY @ UP @ +   ELSE    >BODY   THEN   ;
  32.  
  33. : (IS)          ( cfa --- ) R@ X@  >IS !   R> 2+ >R   ;
  34.  
  35. : IS            ( cfa --- ) STATE @
  36.                 IF  COMPILE (IS)  ELSE  ' >IS !  THEN ; IMMEDIATE
  37.  
  38. CODE    (=:)    ( N1 --- )      \ Store to BODY field of following def
  39.                 MOV ES: BX, 0 [IP]
  40.                 POP 3 [BX]
  41.                 INC IP          INC IP
  42.                 NEXT            END-CODE
  43.  
  44. CODE    (@)     ( --- N1 )      \ Fetch BODY field of following def
  45.                 MOV ES: BX, 0 [IP]
  46.                 PUSH 3 [BX]
  47.                 INC IP          INC IP
  48.                 NEXT            END-CODE
  49.  
  50. : =:            ( N1 T1 --- )
  51.                 STATE @
  52.                 IF      COMPILE (=:)
  53.                 ELSE    ' >BODY !
  54.                 THEN    ; IMMEDIATE
  55.  
  56. CODE    INCR>   ( --- )
  57.                 MOV ES: BX, 0 [IP]
  58.                 MOV AX, 3 [BX]  INC AX          MOV 3 [BX], AX
  59.                 INC IP          INC IP
  60.                 NEXT            END-CODE
  61.  
  62. CODE    DECR>   ( --- )
  63.                 MOV ES: BX, 0 [IP]
  64.                 MOV AX, 3 [BX]  DEC AX          MOV 3 [BX], AX
  65.                 INC IP          INC IP
  66.                 NEXT            END-CODE
  67.  
  68. CODE    +!>     ( N1 --- )
  69.                 POP CX
  70.                 MOV ES: BX, 0 [IP]
  71.                 MOV AX, 3 [BX]  ADD AX, CX      MOV 3 [BX], AX
  72.                 INC IP          INC IP
  73.                 NEXT            END-CODE
  74.  
  75. : !>            ( N1 T1 --- )
  76.                 STATE @
  77.                 IF      COMPILE (=:)
  78.                 ELSE    ' >BODY !
  79.                 THEN    ; IMMEDIATE
  80.  
  81. : @>            ( N1 T1 --- )
  82.                 STATE @
  83.                 IF      COMPILE (@)
  84.                 ELSE    ' >BODY @
  85.                 THEN    ; IMMEDIATE
  86.  
  87. : QUIT          ( -- )
  88.                 SP0 @ 'TIB !    [COMPILE] [
  89.                 BEGIN   BEGIN RP0 @ RP! STATUS QUERY  RUN
  90.                               STATE @ NOT UNTIL ."  ok"   AGAIN  ;
  91.  
  92. DEFER BOOT
  93. DEFER INITSTUFF   ' NOOP IS INITSTUFF
  94. DEFER SEGSET      ' SETYSEG IS SEGSET
  95.  
  96. : WARM          ( -- )
  97.                 [ XLABEL 'WARMBODY ]
  98.                 TRUE ABORT" Warm Start"   ;
  99.  
  100. : COLD          ( -- )
  101.                 [ XLABEL 'COLDBODY ]
  102.                 SEGSET VMODE.SET INITSTUFF
  103.                 BOOT QUIT   ;
  104.  
  105. : START         ( -- )
  106.                 SP0 @ 'TIB !
  107.                 >IN OFF
  108.                 SPAN OFF
  109.                 #TIB OFF
  110.                 LOADING OFF
  111.                 DEFAULT INTERPRET ;
  112.  
  113. DEFER BYEFUNC   ' NOOP IS BYEFUNC
  114.  
  115. : BYE           ( -- )
  116.                 BYEFUNC
  117.                 CR CR ." Giddaye, mate" CR 0 0 BDOS  ;
  118.  
  119. [FORTH] ASSEMBLER
  120.  
  121. LABEL WORIG
  122. HERE ORIGIN 6 + - ORIGIN 4 + !-T  ( WARM ENTRY )
  123.         MOV IP, # 'WARMBODY             \ IP = WARM
  124.         NEXT
  125.         END-CODE
  126.  
  127. LABEL CORIG
  128. HERE ORIGIN 3 + - ORIGIN 1+ !-T  ( COLD ENTRY )
  129.         MOV AX, CS                      \ move CS to AX
  130.         MOV DS, AX
  131.         MOV SS, AX
  132.         MOV BX, YSTART                  \ Read YSTART
  133.         OR BX, BX 0<>                   \ If not reset, then move stuff
  134.      IF
  135.         ADD AX, # #CODESEGS #LISTSEGS + \ Add 128k to get to head space
  136.         MOV ES, AX                      \ move head seg to ES
  137.         MOV BX, # YDP
  138.         ADD BX, UP
  139.         MOV CX, 0 [BX]
  140.         MOV DI, # 0                     \ Clear DI
  141.         MOV SI, YSTART                  \ MOV YSTART to AX
  142.         OR CX, CX 0<>                   \ if YDP was not zero (0)
  143.         IF      CLD
  144.                 REPZ
  145.                 MOVSB                   \ move HEADS to head space
  146.                 CLD
  147.         THEN
  148.         MOV YSEG ES                     \ set YSEG to ES
  149.      THEN
  150.         MOV BX, XMOVED                  \ Has LIST been moved?
  151.         OR BX, BX 0=                    \ If not reset, then move stuff
  152.      IF
  153.         MOV AX, DS                      \ move DS to AX
  154.         ADD AX, # #CODESEGS             \ Add 64k to get to heads
  155.         MOV ES, AX                      \ move head seg to ES
  156.         MOV BX, # XDP
  157.         ADD BX, UP
  158.         MOV CX, 0 [BX]
  159.         MOV DI, # 0                     \ Clear DI
  160.         MOV SI, XSTART                  \ MOV XSTART to AX
  161.         OR CX, CX 0<>                   \ if YDP was not zero (0)
  162.         IF      CLD
  163.                 REPZ
  164.                 MOVSB                   \ move LISTS to LIST space
  165.                 CLD
  166.         THEN
  167.         MOV XSEG ES                     \ set XSEG to ES
  168.      THEN
  169.         MOV AX, CS
  170.         MOV AX, 6
  171.         MOV AL, # 0                     \ AX = contents of address 6
  172.         MOV ' LIMIT 3 + AX              \ LIMIT = 6 @
  173.         SUB AX, # 10
  174.         MOV ' FIRST 3 + AX              \ FIRST = LIMIT - 10h
  175.         SUB AX, # 10
  176.         MOV RP, AX                      \ RP = FIRST - 10h
  177.         MOV BX, # RP0
  178.         ADD BX, UP
  179.         MOV 0 [BX], RP                  \ RP0 = RP
  180.         SUB AX, # 200
  181.         MOV 'TIB AX                     \ TIB = RP - 200 DECIMAL
  182.         MOV BX, # SP0
  183.         ADD BX, UP
  184.         MOV 0 [BX], AX                  \ SP0 = TIB
  185.         MOV SP, AX                      \ SP = TIB
  186.         MOV IP, # 'COLDBODY             \ IP = COLD
  187.         NEXT
  188.         END-CODE
  189.   IN-META
  190.  
  191. HERE UP !-T     ( SET UP USER AREA )
  192.        0 ,      ( TOS )
  193.        0 ,      ( ENTRY )
  194.        0 ,      ( LINK )
  195. INIT-R0 256 - , ( SP0 )
  196.  INIT-R0 ,      ( RP0 )
  197.        0 ,      ( DP )  ( Must be patched later )
  198.        0 ,      ( OFFSET )
  199.       10 ,      ( BASE )
  200.        0 ,      ( HLD )
  201.    FALSE ,      ( PRINTING )
  202.        0 ,      ( YDP ) ( Must be patched by Cold start code )
  203. ' (EMIT) ,      ( EMIT )
  204. ' (KEY?) ,      ( KEY? )
  205. ' (KEY)  ,      ( KEY  )
  206. ' (TYPE) ,      ( TYPE )
  207.        0 ,      ( XDP ) ( Must be patched by Cold start code )
  208.  
  209. : DEPTH         ( -- n )   SP@ SP0 @ SWAP - 2/   ;
  210.  
  211. VARIABLE MAX.S
  212.  
  213. : .S            ( -- )    DEPTH 0< ABORT" Stack UNDERFLOW !! "
  214.                 DEPTH ?DUP MAX.S @ 1 < IF 4 MAX.S ! THEN
  215.                 IF      DUP ."  [" 1 .R ." ]" 0 SWAP 1- MAX.S @ 1- MIN
  216.                         DO I PICK 7 U.R BL FEMIT -1 +LOOP
  217.                 ELSE    ."  Stack Empty. "  THEN ;
  218.  
  219. : .ID           ( nfa -- )
  220.                 DUP 1+ DUP YC@ ROT YC@ 31 AND 0
  221.                ?DO      DUP 127 AND FEMIT 128 AND
  222.                         IF   ASCII _ 128 OR   ELSE  1+ DUP YC@  THEN
  223.                 LOOP    2DROP BL FEMIT ;
  224.  
  225. : DUMP          ( addr len -- )
  226.               0 DO   CR DUP 6 .R SPACE  16 0 DO   DUP C@ 3 .R 1+   LOOP
  227.             16 +LOOP   DROP   ;
  228.  
  229. : RECURSE       ( -- ) LAST @ NAME> X,  ;  IMMEDIATE
  230.  
  231. : H.            ( N1 --- ) BASE @ >R HEX U. R> BASE ! ;
  232.  
  233. VARIABLE LMARGIN    0 LMARGIN !-T
  234. VARIABLE RMARGIN   70 RMARGIN !-T
  235. VARIABLE TABSIZE    8 TABSIZE !-T
  236.  
  237. : ?LINE         ( n -- )
  238.                 #OUT @ +  RMARGIN @ > IF CR LMARGIN @ SPACES THEN ;
  239.  
  240. : ?CR           ( -- )  0 ?LINE  ;
  241.  
  242. : TAB           ( --- ) #OUT @ TABSIZE @ MOD TABSIZE @ SWAP - SPACES ;
  243.  
  244. : \             ( --- ) SPAN @ >IN ! ; IMMEDIATE
  245.  
  246. ' (.")                            :RESOLVES <(.")>
  247. ' (")                             :RESOLVES <(")>
  248. ' (;CODE)                         :RESOLVES <(;CODE)>
  249. ' (;USES)                         :RESOLVES <(;USES)>
  250. ' (IS)                            :RESOLVES <(IS)>
  251. ' (ABORT")                        :RESOLVES <(ABORT")>
  252.  [ASSEMBLER] >NEXT    META         RESOLVES <VARIABLE>
  253.  [ASSEMBLER] DOUSER-DEFER META     RESOLVES <USER-DEFER>
  254.  [ASSEMBLER] DOUSER-VARIABLE META  RESOLVES <USER-VARIABLE>
  255.  
  256. ' DEFINITIONS :RESOLVES DEFINITIONS
  257. ' [           :RESOLVES [
  258. ' ?MISSING    :RESOLVES ?MISSING
  259. ' QUIT        :RESOLVES QUIT
  260. ' .ID         :RESOLVES .ID
  261.  
  262. \ Fill in some defered words
  263. ' CRLF          IS CR
  264. ' NOOP          IS WHERE
  265. ' CR            IS STATUS
  266. ' (SOURCE)      IS SOURCE
  267. ' START         IS BOOT
  268. ' (NUMBER)      IS NUMBER
  269. ' (?ERROR)      IS ?ERROR
  270.  
  271. ' FORTH >BODY-T CURRENT !-T
  272. ' FORTH >BODY-T CONTEXT !-T
  273. ' NORM-KEYTBL >BODY-T @-T KEYTBL !-T
  274. HERE-T  DP UP @-T + !-T               ( INIT USER DP )
  275. #USER-T @ #USER !-T                   ( INIT USER VAR COUNT )
  276. TRUE  CAPS !-T                        ( SET TO IGNORE CASE )
  277. TRUE WARNING !-T                      ( SET TO ISSUE WARNINGS )
  278. 31 WIDTH !-T                          ( 31 CHARACTER NAMES )
  279. VOC-LINK-T @ VOC-LINK !-T             ( INIT VOC-LINK )
  280.  
  281. CR .( Unresolved references: )          CR   .UNRESOLVED ?NEWPAGE
  282. CR .(     Statistics: )
  283. CR .( Last  Host Address:        )      [FORTH] HERE U.
  284. CR .( First Target Code Address: )      META 256 THERE U.
  285. CR .( Last  Target Code Address: )      META HERE-T THERE U.
  286.                                         META 256 THERE          \ start addr
  287.                                         SVXSEG     XSTART !-T
  288. CR .( CODE space used:           )      HERE-T U.
  289. CR .( LIST space used:           )      HERE-X U.
  290. CR .( HEAD space used:           )      HERE-Y U.
  291.                                         HERE-X     ALLOT-T
  292.                                                    HERE-X XDP UP @-T + !-T
  293.                                         SVYSEG DUP YSTART !-T
  294.                                         0 XMOVED !-T
  295.                                         HERE-Y +   HERE-Y YDP UP @-T + !-T
  296.                                         DUP THERE ONLY FORTH ALSO SP@ SWAP -
  297. CR .( Free Symbol Table bytes:   )      U.
  298. ONLY FORTH ALSO
  299.  
  300. .ELAPSED
  301.  
  302. ( A1 N1 --- )   ZSAVE FKERNEL.COM   FORTH
  303.  
  304. CR .( Now type INSTALL <enter> at the DOS prompt.)
  305. CR
  306.  
  307.