home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FFA.ZIP / KERNEL3.SEQ < prev    next >
Encoding:
Text File  |  1988-01-11  |  15.3 KB  |  446 lines
  1. \ KERNEL3.SEQ   More kernel stuff
  2.  
  3. FILES DEFINITIONS
  4.  
  5. VARIABLE KERNEL3.SEQ
  6.  
  7. FORTH DEFINITIONS
  8.  
  9. : >TYPE         ( adr len -- )
  10.                 TUCK PAD SWAP CMOVE   PAD SWAP TYPE  ;
  11.  
  12. : .(            ( -- )  ASCII ) PARSE >TYPE  ; IMMEDIATE
  13.  
  14. : (             ( -- )  ASCII ) PARSE 2DROP  ; IMMEDIATE
  15.  
  16. CODE TRAVERSE   ( addr direction -- addr' )
  17.                 POP CX          POP BX
  18.                 ADD BX, CX      PUSH ES
  19.                 MOV ES, YSEG
  20.           BEGIN
  21.                 MOV ES: AL, 0 [BX]      AND AL, # 128
  22.        0= WHILE
  23.                 ADD BX, CX
  24.           REPEAT
  25.                 POP ES          PUSH BX
  26.                 NEXT            END-CODE
  27.  
  28. : DONE?         ( n -- f )
  29.                 STATE @ <>   END? @ OR   END? OFF   ;
  30.  
  31. HEX
  32.  
  33. : CNHASH        ( CFA-YA )
  34.                 0FE00 AND FLIP ;  DECIMAL
  35.  
  36. : CNSRCH        ( CFA YA MAXYA - NFA failf )
  37.                 SWAP 2+ 2+
  38.                 BEGIN 2DUP U> WHILE ( cfa mxy nfa )
  39.                         DUP YC@ 31 AND + 1+ DUP Y@
  40.                         3 PICK =
  41.                         IF -ROT 2DROP 1- -1 TRAVERSE FALSE EXIT THEN
  42.             6 + REPEAT   2DROP TRUE ;
  43.  
  44. : N>LINK        2-   ;
  45. : L>NAME        2+   ;
  46. : BODY>         3 -  ;
  47.  
  48. : NAME>         1 TRAVERSE   1+ Y@  ;
  49. : LINK>         L>NAME   NAME>   ;
  50. : >BODY         3 +  ;
  51.  
  52. HERE-Y 4 +     \ Step from view field to name field
  53.  
  54. : NO-NAME ;
  55.  
  56. : >NAME         ( cfa - nfa )
  57.                 DUP CNHASH DUP Y@ SWAP
  58.                 2+ Y@ ( cfa sya mxya ) CNSRCH
  59.                 IF      DROP (LIT) [ ROT ,-X ] THEN    ;
  60.  
  61. : >LINK         >NAME   N>LINK   ;
  62. : >VIEW         >LINK   2-   ;
  63. : VIEW>         2+   LINK>   ;
  64.  
  65. CODE HASH       ( str-addr voc-ptr -- thread )
  66.                 POP CX          POP BX
  67.                 MOV AL, 0 [BX]  ADD AL, 1 [BX]
  68. \ ****          INC BX          MOV AL, 0 [BX]
  69.                 AND AX, # #THREADS 1-
  70.                 SHL AX, # 1     ADD AX, CX
  71.                 1PUSH           END-CODE
  72.  
  73. CODE (FIND)     ( here alf -- cfa flag | here false )
  74.                 POP DX          OR DX, DX
  75.              0= IF
  76.                 SUB AX, AX      1PUSH
  77.             THEN                POP DI          PUSH ES         PUSH DI
  78.                 MOV ES, YSEG
  79.             BEGIN
  80.                 MOV BX, DX      INC BX          INC BX
  81.                 POP DI ( here ) PUSH DI         MOV ES: AL, 0 [BX]
  82.                 XOR AL, 0 [DI]  AND AL, # 63
  83.              0= IF
  84.                 BEGIN
  85.                         INC BX  INC DI          MOV ES: AL, 0 [BX]
  86.                         XOR AL, 0 [DI]
  87.                 0<> UNTIL
  88.                         AND AL, # 127
  89.                      0= IF
  90.                         POP DI                  MOV ES: AX, 1 [BX]
  91.                         PUSH AX                 MOV BX, DX
  92.                         INC BX                  INC BX
  93.                         MOV ES: AL, 0 [BX]      AND AL, # 64
  94.                         0<> IF
  95.                             MOV AX, # 1
  96.                         ELSE
  97.                             MOV AX, # -1
  98.                         THEN
  99.                         POP DX    POP ES        PUSH DX
  100.                         1PUSH
  101.                     THEN
  102.                  THEN
  103.                 MOV BX, DX      MOV ES: DX, 0 [BX]
  104.                 OR DX, DX
  105.              0= UNTIL
  106.                 POP DX          POP ES          PUSH DX
  107.                 SUB AX, AX
  108.                 1PUSH           END-CODE
  109.  
  110. CODE DROP.CONTEXT.I2*+@DUP   ( A1 --- N1 )
  111.                 POP AX
  112.                 MOV AX, 0 [RP]
  113.                 ADD AX, 2 [RP]
  114.                 SHL AX, # 1
  115.                 MOV BX, # CONTEXT
  116.                 ADD BX, AX
  117.                 PUSH 0 [BX]
  118.                 PUSH 0 [BX]
  119.                 NEXT
  120.                 END-CODE
  121.  
  122.                                 \ DUP PRIOR @ OVER PRIOR ! =
  123. CODE PRIOR.CHECK ( N1 --- N1 F1 )
  124.                 POP AX
  125.                 PUSH AX
  126.                 MOV BX, PRIOR
  127.                 MOV PRIOR AX
  128.                 CMP BX, AX
  129.             0<> IF
  130.                 MOV AX, # FALSE
  131.                 1PUSH
  132.             THEN
  133.                 MOV AX, # TRUE
  134.                 1PUSH
  135.                 END-CODE
  136.  
  137. CODE OVER.SWAP.HASH.@
  138.                 POP AX          POP DX
  139.                 PUSH DX         PUSH DX
  140.                 PUSH AX         POP CX
  141.                 POP BX
  142.                 MOV AL, 0 [BX]  ADD AL, 1 [BX]
  143. \ ****          INC BX          MOV AL, 0 [BX]
  144.                 AND AX, # #THREADS 1-
  145.                 SHL AX, # 1     ADD AX, CX
  146.                 MOV BX, AX      MOV AX, 0 [BX]
  147.                 1PUSH           END-CODE
  148.  
  149. : FIND          ( addr -- cfa flag | addr false )
  150.                 DUP C@
  151.         IF   PRIOR OFF   FALSE   #VOCS 0
  152.                 DO      DROP.CONTEXT.I2*+@DUP
  153.                         IF      PRIOR.CHECK
  154.                                 IF   DROP FALSE
  155.                                 ELSE   OVER.SWAP.HASH.@ (FIND)  DUP ?LEAVE
  156.                         THEN THEN   LOOP
  157.         ELSE    DROP END? ON  ['] NOOP 1  THEN  ;
  158.  
  159. : DEFINED       ( -- here 0 | cfa [ -1 | 1 ] )
  160.                 BL WORD  ?UPPERCASE  FIND   ;
  161.  
  162. : (?STACK)      ( -- )   ( System dependant )
  163.                 SP@ SP0 @ SWAP U<   ABORT" Stack Underflow"
  164.                 SP@ PAD U<   ABORT" Stack Overflow"
  165.                 SP@ PAD 200 + U< IF CR ."  Running out of memory! " THEN
  166.         #HEADSEGS YHERE 0 16 UM/MOD NIP 6 + < ABORT" Out of HEAD space"
  167.         #LISTSEGS XHERE 0 16 UM/MOD NIP 6 + < ABORT" Out of LIST space" ;
  168.  
  169. DEFER ?STACK    ' (?STACK) IS ?STACK
  170.  
  171. : INTERP        ( -- )
  172.                 BEGIN   ?STACK  DEFINED
  173.                         IF     EXECUTE
  174.                         ELSE   NUMBER  DOUBLE? NOT IF  DROP  THEN
  175.                         THEN   FALSE DONE?
  176.                 UNTIL   ;
  177.  
  178. DEFER STATUS    ( -- )
  179.  
  180. DEFER INTERPRET ' INTERP IS INTERPRET
  181.  
  182. : PRINT         ( --- ) PRINTING ON INTERPRET PRINTING OFF ;
  183.  
  184. : <ALLOT>       ( n -- )      DP +!   ;
  185.  
  186. DEFER ALLOT     ' <ALLOT> IS ALLOT
  187.  
  188. CODE <,>        ( N --- )
  189.                 MOV BX, UP
  190.                 MOV AX, DP [BX]
  191.                 MOV CX, # 2
  192.                 ADD DP [BX], CX
  193.                 MOV BX, AX
  194.                 POP CX
  195.                 MOV 0 [BX], CX
  196.                 NEXT
  197.                 END-CODE
  198.  
  199. DEFER ,         ' <,> IS ,
  200.  
  201.  
  202. CODE <C,>       ( N --- )
  203.                 MOV BX, UP
  204.                 MOV AX, DP [BX]
  205.                 INC DP [BX] WORD
  206.                 MOV BX, AX
  207.                 POP CX
  208.                 MOV 0 [BX], CL
  209.                 NEXT
  210.                 END-CODE
  211.  
  212. DEFER C,        ' <C,> IS C,
  213.  
  214. : ALIGN         ( HERE 1 AND IF  BL C,  THEN )  ; IMMEDIATE
  215. : EVEN          ( DUP 1 AND + ) ;  IMMEDIATE
  216. : COMPILE       ( -- )   R> DUP 2+ >R   X@ X,   ;
  217. : CCOMPILE      ( -- )   R> DUP 2+ >R   X@  ,   ;
  218. : IMMEDIATE     ( -- )   64 ( Precedence bit ) LAST @ YCSET  ;
  219. : LITERAL       ( n -- )  COMPILE (LIT) X, ; IMMEDIATE
  220. : DLITERAL      ( d# -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE
  221.  
  222. : ASCII         ( -- n )   BL WORD   1+ C@
  223.                 STATE @ IF   [COMPILE] LITERAL   THEN   ; IMMEDIATE
  224.  
  225. : CONTROL       ( -- n )   BL WORD   1+ C@  31 AND
  226.                 STATE @ IF   [COMPILE] LITERAL   THEN   ; IMMEDIATE
  227.  
  228. : CRASH         ( -- ) R> 2- X@ >NAME CR .ID TRUE
  229.                 ABORT" <- is an Uninitialized execution vector."  ;
  230.  
  231. : ?MISSING      ( f -- )
  232.                 IF   'WORD COUNT TYPE
  233.                 TRUE ABORT"  <- huh?, I'm confused! "   THEN   ;
  234.  
  235. : '             ( -- cfa )      DEFINED 0= ?MISSING   ;
  236.  
  237. : [']           ( -- )          ' [COMPILE] LITERAL   ; IMMEDIATE
  238. : [COMPILE]     ( -- )          ' X,   ; IMMEDIATE
  239. : (")           ( -- addr len ) R> DUP 2+ >R X@ COUNT ;
  240. : (.")          ( -- )          R> DUP 2+ >R X@ COUNT TYPE   ;
  241. : ,"            ( -- )          ASCII " PARSE TUCK 'WORD PLACE 1+ ALLOT ALIGN ;
  242. : ."            ( -- )          COMPILE (.") HERE X, ,"   ;   IMMEDIATE
  243. : "             ( -- )          COMPILE (")  HERE X, ,"   ;   IMMEDIATE
  244. : ">$           ( A1 -- A2 )    DROP 1- ;
  245.  
  246. VARIABLE FENCE
  247.  
  248. : TRIM          ( faddr voc-addr -- )
  249.                 #THREADS 0
  250.                 DO      2DUP @ BEGIN   2DUP U> NOT WHILE Y@ REPEAT
  251.                         NIP OVER ! 2+
  252.                 LOOP    2DROP   ;
  253.  
  254. : (FRGET)       ( code-addr view-addr -- )
  255.                 DUP FENCE @ U< ABORT" Below fence"  ( ca va )
  256.                 OVER VOC-LINK @ BEGIN   2DUP U< WHILE   @ REPEAT
  257.                 DUP VOC-LINK !  ( ca va ca pt ) NIP
  258.                 BEGIN   DUP WHILE   2DUP #THREADS 2* - TRIM   @   REPEAT
  259.                 DROP    YDP !
  260.                 DUP 1+ @ OVER >BODY +
  261.                 (LIT)   TRIM DUP 1+ @ SWAP >BODY + =    \ If it's a : def
  262.                 IF      DUP >BODY @ XDP !               \ Set back XHERE too!
  263.                 THEN    DP !  ;
  264.  
  265. DEFER WHERE
  266. DEFER ?ERROR
  267.  
  268. : (?ERROR)      ( adr len f -- )
  269.                 IF      >R >R   SP0 @ SP!   PRINTING OFF
  270.                         R> R> SPACE TYPE SPACE   QUIT
  271.                 ELSE    2DROP  THEN  ;
  272.  
  273. : (ABORT")      ( f -- )        R@ X@ COUNT ROT ?ERROR   R> 2+ >R ;
  274. : ABORT"        ( -- )          COMPILE (ABORT") HERE X, ," ;   IMMEDIATE
  275. : ABORT         ( -- )          TRUE ABORT" "  ;
  276.  
  277. : FORGET        ( -- )
  278.                 BL WORD ?UPPERCASE DUP CURRENT @ HASH @
  279.                 (FIND) 0= ?MISSING DUP >VIEW (FRGET) ;
  280.  
  281. : ?CONDITION    ( f -- )        NOT ABORT" Conditionals Wrong"   ;
  282.  
  283. : >MARK         ( -- addr )     XHERE 0 X,   ;
  284. : >RESOLVE      ( addr -- )     XHERE SWAP X!   ;
  285. : <MARK         ( -- addr )     XHERE    ;
  286. : <RESOLVE      ( addr -- )     X,   ;
  287.  
  288. : ?>MARK        ( -- f addr )   TRUE >MARK   ;
  289. : ?>RESOLVE     ( f addr -- )   SWAP ?CONDITION >RESOLVE  ;
  290. : ?<MARK        ( -- f addr )   TRUE   <MARK   ;
  291. : ?<RESOLVE     ( f addr -- )   SWAP ?CONDITION <RESOLVE  ;
  292.  
  293. : LEAVE         COMPILE (LEAVE)                                 ; IMMEDIATE
  294. : ?LEAVE        COMPILE (?LEAVE)                                ; IMMEDIATE
  295. : BEGIN         COMPILE DOBEGIN ?<MARK                          ; IMMEDIATE
  296. : THEN          COMPILE DOTHEN ?>RESOLVE                        ; IMMEDIATE
  297. : DO            COMPILE (DO)   ?>MARK                           ; IMMEDIATE
  298. : ?DO           COMPILE (?DO)  ?>MARK                           ; IMMEDIATE
  299. : LOOP          COMPILE (LOOP)  2DUP 2+ ?<RESOLVE ?>RESOLVE     ; IMMEDIATE
  300. : +LOOP         COMPILE (+LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE     ; IMMEDIATE
  301. : UNTIL         COMPILE ?UNTIL     ?<RESOLVE                    ; IMMEDIATE
  302. : AGAIN         COMPILE  DOAGAIN   ?<RESOLVE                    ; IMMEDIATE
  303. : REPEAT        2SWAP COMPILE DOREPEAT ?<RESOLVE ?>RESOLVE      ; IMMEDIATE
  304. : IF            COMPILE  ?BRANCH  ?>MARK                        ; IMMEDIATE
  305. : ELSE          COMPILE  BRANCH ?>MARK  2SWAP ?>RESOLVE         ; IMMEDIATE
  306. : WHILE         COMPILE ?WHILE ?>MARK                           ; IMMEDIATE
  307.  
  308. : ,VIEW         ( -- )  LOADLINE @ Y, ;
  309.  
  310. : "HEADER       ( STR --- )
  311.                 WARNING @  IF DUP FIND NIP IF
  312.                 DUP  CR  COUNT TYPE ."  isn't unique " THEN  THEN ( str )
  313.                 ALIGN  YHERE 2- Y@ CNHASH  HERE CNHASH  <>
  314.                 IF      YHERE HERE CNHASH DUP Y@ ROT MIN SWAP
  315.                         Y! ( >NAME hash entry )
  316.                 THEN    ,VIEW
  317.                 YHERE OVER CURRENT @ HASH DUP @  Y,  ( link  ) ! ( current )
  318.                 YHERE LAST ! ( remember nfa )
  319.                 YHERE ?CS: ROT  DUP C@  WIDTH @  MIN 1+ >R  ( yh cs str )
  320.                 YHERE YS: R@ CMOVEL ( copy str ) R> YDP +! ALIGN ( nam )
  321.                 128 SWAP YCSET   128 YHERE 1- YCSET   ( delimiter Bits )
  322.                 HERE Y, ( CFA in header )
  323.                 YHERE HERE CNHASH 2+ Y! ( valid stopper in next n hash entry)
  324.                 ;
  325.  
  326. : ,CALL         232 C, 0 HERE 2+ - , ;        \ Compiles addr 0000 !!!!
  327. : ,JUMP         233 C, 0 HERE 2+ - , ;
  328.  
  329. : <HEADER>      ( | name --- )
  330.                 BL WORD ?UPPERCASE "HEADER ;
  331.  
  332. DEFER HEADER    ' <HEADER> IS HEADER
  333.  
  334. \ : "CREATE       ( A1 --- ) "HEADER ,CALL ;USES >NEXT ,-X
  335.  
  336. : CREATE        ( | name -- )  HEADER ,CALL ;USES >NEXT ,-X
  337.  
  338. : !CSP          ( -- )  SP@ CSP !   ;
  339.  
  340. : ?CSP          ( -- )  SP@ CSP @ <> ABORT" Stack Changed"   ;
  341.  
  342. : HIDE          ( -- )  LAST @ DUP N>LINK Y@ SWAP CURRENT @ YHASH ! ;
  343.  
  344. : REVEAL        ( -- )  LAST @ DUP N>LINK    SWAP CURRENT @ YHASH ! ;
  345.  
  346. : (;USES)       ( -- )
  347.                 R> X@ LAST @ NAME> DUP >R 3 + - R> 1+ ! ;
  348.  
  349. : X(;CODE)       ( -- )
  350.                 R> X@ LAST @ NAME>
  351.                 DUP >R 232 ( CALL ) R@ C!       \ Make a CALL not JUMP
  352.                 3 + - R> 1+ !  ;
  353.  
  354. DEFER (;CODE)   ' X(;CODE) IS (;CODE)
  355.  
  356. : DOES>         ( -- )
  357.                 COMPILE (;CODE) HERE X, 232 ( CALL ) C,
  358.                 [ [FORTH] ASSEMBLER DODOES META ] LITERAL
  359.                 HERE 2+ - , XHERE , ; IMMEDIATE
  360.  
  361. VOCABULARY ASSEMBLER
  362.  
  363. DEFER SETASSEM  \ Setup for assembly stuff to follow
  364.  
  365. ' NOOP IS SETASSEM
  366.  
  367. : [             ( -- )  STATE OFF   ;   IMMEDIATE
  368.  
  369. : ;USES         ( -- )  ?CSP   COMPILE  (;USES) HERE X,
  370.                 [COMPILE] [   REVEAL   ASSEMBLER   ; IMMEDIATE
  371.  
  372. : ;CODE         ( -- )  ?CSP   COMPILE  (;CODE) HERE X,
  373.                 [COMPILE] [   REVEAL   SETASSEM ; IMMEDIATE
  374.  
  375. : (])           ( -- )
  376.                 STATE ON
  377.         BEGIN   ?STACK   DEFINED DUP
  378.                 IF      0> IF    EXECUTE   ELSE   X,   THEN
  379.                 ELSE   DROP   NUMBER  DOUBLE?
  380.                         IF          [COMPILE] DLITERAL
  381.                         ELSE DROP   [COMPILE] LITERAL   THEN
  382.                 THEN   TRUE DONE?
  383.         UNTIL   ;
  384.  
  385. DEFER ]         ' (]) IS ]
  386.  
  387. : MAKEDUMMY     ( NAME --- )
  388.                 HEADER ,JUMP XHERE , COMPILE UNNEST ;USES  NEST ,-X
  389.  
  390. : ANEW          ( NAME --- )
  391.                 >IN @ >R DEFINED NIP  R@ >IN !
  392.                 IF      FORGET
  393.                 THEN    R> >IN !  MAKEDUMMY   ;
  394.                                                         \ Add if needed
  395. : :             ( -- )
  396.                 !CSP   CURRENT @ CONTEXT !
  397.                 HEADER ,JUMP XHERE ,
  398.                 HIDE    ]
  399.                 ;USES   NEST ,-X
  400.  
  401. : ;             ( -- )
  402.                 STATE @ 0= ABORT" Not Compiling!"
  403.                 ?CSP   COMPILE UNNEST   REVEAL   [COMPILE] [  ; IMMEDIATE
  404.  
  405. : RECURSIVE     ( -- )  REVEAL ;   IMMEDIATE
  406.  
  407. : CONSTANT      ( n -- ) CREATE ,   ;USES DOCONSTANT ,-X
  408.  
  409. : VARIABLE      ( -- )   CREATE 0 ,   ;USES >NEXT ,-X
  410.                                         \ not really needed, but pretty.
  411.  
  412. : DEFER         ( -- )
  413.                 CREATE   ['] CRASH ,  ;USES   DODEFER  ,-X
  414.  
  415. DODEFER RESOLVES <DEFER>
  416.  
  417. : DEFERS        ( T1 -- )  ' >BODY @ X, ; IMMEDIATE
  418.  
  419. : UDEFERS       ( T1 -- )  ' >BODY @ UP @ + @ X, ; IMMEDIATE
  420.  
  421. : UNDEFER       ( T1 -- )  ' >BODY @ DUP X@ >BODY @ X@ SWAP X! ;
  422.  
  423. : VOCABULARY    ( -- )  CREATE   #THREADS 0 DO   0 ,  LOOP
  424.                         HERE  VOC-LINK @ ,  VOC-LINK !
  425.                         DOES> CONTEXT !  ;
  426.  
  427.  RESOLVES <VOCABULARY>
  428.  
  429. : DEFINITIONS   ( -- ) CONTEXT @ CURRENT !   ;
  430.  
  431. : 2CONSTANT     CREATE   , ,    ( d# -- )
  432.                 DOES> 2@   ;    ( -- d# )   DROP
  433.  
  434. : 2VARIABLE     0 0 2CONSTANT   ( -- )
  435.                 DOES> ;         ( -- addr )   DROP
  436.  
  437. : <RUN>         ( -- )
  438.         STATE @ IF      ]
  439.                         STATE @ NOT
  440.                         IF   INTERPRET   THEN
  441.                 ELSE    INTERPRET   THEN   ;
  442.  
  443. DEFER RUN       ' <RUN> IS RUN
  444.  
  445.  
  446.