home *** CD-ROM | disk | FTP | other *** search
/ EuroCD 3 / EuroCD 3.iso / Programming / PPCcforth / forth.line < prev    next >
Encoding:
Text File  |  1998-06-24  |  11.2 KB  |  495 lines
  1. ------------------ SCREEN 0 ------------------
  2.  
  3.  
  4. ================================================================
  5. ||      C-CODED FIG-FORTH for UNIX* systems by ALLAN PRATT    ||
  6. ||                                                            ||
  7. ||      INCLUDES \ COMMENTS,                                  ||
  8. ||               CASE..OF..ENDOF..ENDCASE                     ||
  9. ||               UNTHREAD, EDITOR                             ||
  10. ||               REFORTH,                                     ||
  11. ||               "ALIAS NEW OLD"                              ||
  12. ||      AND OTHER NICE THINGS.                                ||
  13. || ( * UNIX is a trademark of Bell Labs )                     ||
  14. ================================================================
  15.  
  16.  
  17.  
  18. ------------------ SCREEN 1 ------------------
  19. ( UNTHREAD VERSION 2 / SCREEN 1 OF 3 )
  20. : DOQUOTE                       \ AFTER (.")
  21.   34 EMIT WORDSIZE + DUP C@ OVER 1+ SWAP TYPE
  22.   34 EMIT SPACE DUP C@ + 1+ ;
  23.  
  24. : DOLIT         \ AFTER LIT, BRANCHES, AND (LOOP)S
  25.   WORDSIZE + DUP @ . WORDSIZE + ;
  26.  
  27.  
  28.  
  29.  
  30. -->
  31.  
  32.  
  33.  
  34.  
  35. ------------------ SCREEN 2 ------------------
  36. ( UNTHREAD VERSION 2 / SCREEN 2 OF 3 )
  37. : DOWORD        \ MAIN UNTHREADER
  38.   DUP @ WORDSIZE + DUP NFA ID.  CASE
  39.     ' LIT       OF DOLIT        ENDOF
  40.     ' 0BRANCH   OF DOLIT        ENDOF
  41.     ' BRANCH    OF DOLIT        ENDOF
  42.     ' (LOOP)    OF DOLIT        ENDOF
  43.     ' (+LOOP)   OF DOLIT        ENDOF
  44.     ' (.")      OF DOQUOTE      ENDOF
  45.     ' ;S        OF DROP 0       ENDOF \ LEAVE 0
  46.     DUP         OF WORDSIZE +   ENDOF \ DEFAULT
  47.   ENDCASE ;
  48.  
  49. -->
  50.  
  51.  
  52. ------------------ SCREEN 3 ------------------
  53. ( UNTHREAD VERSION 2 / SCREEN 3 OF 3 )
  54. : UNTHREAD      \ USAGE: UNTHREAD WORD
  55.   [COMPILE] ' DUP CFA @
  56.   ' DOWORD CFA @ <> 27 ?ERROR   \ NOT THREADED
  57.   CR ." : " DUP NFA ID. SPACE
  58.   BEGIN
  59.     DOWORD
  60.     OUT @ C/L > IF CR THEN
  61.     -DUP WHILE
  62.   REPEAT ;
  63.  
  64. CR ." UNTHREAD READY"
  65.  
  66. ;S
  67.  
  68.  
  69. ------------------ SCREEN 4 ------------------
  70. ( ERROR MESSAGES )
  71. EMPTY STACK
  72.  
  73.  
  74. ISN'T UNIQUE
  75.  
  76.  
  77. FULL STACK
  78.  
  79.  
  80.  
  81.  
  82.  
  83.  
  84.  
  85. C-CODED figFORTH by ALLAN PRATT / APRIL 1985
  86. ------------------ SCREEN 5 ------------------
  87. MSG # 16
  88. MUST BE COMPILING
  89. MUST BE EXECUTING
  90. UNMATCHED STRUCTURES
  91. DEFINITION NOT FINISHED
  92. WORD IS PROTECTED BY FENCE
  93. MUST BE LOADING
  94.  
  95. CONTEXT ISN'T CURRENT
  96.  
  97.  
  98. ALIAS: NOT A COLON DEFINITION
  99. ALIAS: CAN'T ALIAS A NULL WORD
  100.  
  101.  
  102.  
  103. ------------------ SCREEN 6 ------------------
  104. ." LOADING EDITOR FOR VT100" CR
  105.  
  106. : CLS                        \ clear screen and home cursor
  107.   27 EMIT ." [2J" 27 EMIT ." [H"
  108. ;
  109.  
  110. : LOCATE   \ 0 16 LOCATE positions cursor at line 16, column 0
  111.   27 EMIT 91 EMIT 1+ 1 .R 59 EMIT 1+ 1 .R 72 EMIT ;
  112.  
  113. : STANDOUT                   \ This can be a null word
  114.   27 EMIT ." [7m" ;
  115.  
  116. : STANDEND                   \ This can be a null word, too.
  117.   27 EMIT ." [m" ;
  118.  
  119. ;S   \ CONTINUE LOADING EDITOR
  120. ------------------ SCREEN 7 ------------------
  121. ." LOADING EDITOR FOR ADM5" CR
  122.  
  123. : CLS 26 EMIT ;
  124.  
  125. : LOCATE
  126.   27 EMIT 61 EMIT
  127.   32 + EMIT 32 + EMIT ;
  128.  
  129.  
  130. : STANDOUT
  131.   27 EMIT 71 EMIT ;
  132.  
  133. : STANDEND
  134.   27 EMIT 71 EMIT ;
  135.  
  136. ;S   \ continue loading editor
  137. ------------------ SCREEN 8 ------------------
  138. ( Reserved for more terminals; set the name of the terminal
  139.   as a constant in screen 10 )
  140. ;S
  141.  
  142.  
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154. ------------------ SCREEN 9 ------------------
  155. ( Reserved for more terminals. Set the name of the terminal
  156.   as a constant in screen 10 )
  157. ;S
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171. ------------------ SCREEN 10 ------------------
  172. ( EDITOR -- SCREEN 1 OF 19 -- VARIABLES )
  173. DECIMAL
  174. 0 VARIABLE ROW          0 VARIABLE COL
  175. 0 VARIABLE EDIT-SCR     0 VARIABLE SCREEN-IS-MODIFIED
  176. 0 VARIABLE MUST-UPDATE  0 VARIABLE LAST-KEY-STRUCK
  177. 0 VARIABLE CURSOR-IS-DIRTY
  178.  
  179. 0 VARIABLE KEYMAP  WORDSIZE 255 *  ALLOT
  180.            KEYMAP  WORDSIZE 256 *  ERASE
  181.  
  182. 0 VARIABLE SCR-BUFFER B/BUF B/SCR * WORDSIZE - ALLOT
  183.  
  184. ( TERMINAL CONSTANTS -- VALUE IS SCREEN NUMBER TO LOAD )
  185. 6 CONSTANT VT100   7 CONSTANT ADM5
  186.  
  187. -->
  188. ------------------ SCREEN 11 ------------------
  189. ( EDITOR -- SCREEN 2 OF 19 -- SCREEN STUFF )
  190.  
  191. CR ." ENTER THE TYPE OF TERMINAL YOU ARE USING. TYPE ONE OF:"
  192. CR ."      VT100   ADM5" CR   \ list the constants from scr 10
  193.  
  194. REFORTH          \ this word gets & interprets one line.
  195. LOAD             \ load the right screen; VT100 = 6, ADM5 = 7
  196.  
  197. : EXIT-EDIT
  198.   0 16 LOCATE QUIT ;
  199. : ABORT-EDIT
  200.   0 15 LOCATE MESSAGE ;
  201.  
  202. : BIND-ADDR          ( C -- ADDR where binding is stored )
  203.   WORDSIZE * KEYMAP + ;
  204. -->
  205. ------------------ SCREEN 12 ------------------
  206. ( EDITOR -- SCREEN 3 OF 19 -- I/O )
  207.  
  208. : ^EMIT        ( OUTPUT W/ESC AND ^ )
  209.   DUP 127 > IF ." ESC-" 128 - THEN
  210.   DUP 32  < IF ." ^" 64 + THEN
  211.   EMIT ;
  212.  
  213. : BACK-WRAP     ( DECR EDIT SCR. AND PUT CURSOR AT BOTTOM )
  214.   EDIT-SCR -- C/L 1- COL ! 15     ROW ! 1 MUST-UPDATE ! ;
  215. : FORWARD-WRAP  ( INCR EDIT SCR. AND PUT CURSOR AT TOP )
  216.   EDIT-SCR ++ 0 COL ! 0 ROW ! 1 MUST-UPDATE ! ;
  217. : ED-KEY       ( INPUT W/ESC FOR HI BIT )
  218.   KEY DUP 27 = IF DROP KEY 128 + THEN
  219.   DUP LAST-KEY-STRUCK ! ;
  220.  
  221. -->
  222. ------------------ SCREEN 13 ------------------
  223. ( EDITOR -- SCREEN 4 OF 19 -- BINDING WORDS )
  224. : (BIND)         ( CFA K -- STORES INTO KEYMAP )
  225.   BIND-ADDR !
  226. ;
  227.  
  228. : BIND-TO-KEY    ( "BIND-TO-KEY NAME" ASKS FOR KEY )
  229.   [COMPILE] ' CFA
  230.   ." KEY: " ED-KEY DUP ^EMIT SPACE
  231.   (BIND) ;
  232.  
  233. : DESCRIBE-KEY
  234.   ." KEY: " ED-KEY DUP ^EMIT SPACE
  235.   BIND-ADDR @ -DUP IF NFA ID.
  236.                         ELSE ." SELF-INSERT"
  237.                         THEN SPACE ;
  238. -->
  239. ------------------ SCREEN 14 ------------------
  240. ( EDITOR -- SCREEN 5 OF 19 -- PRIMITIVE OPS )
  241.  
  242. : PREV-LINE ROW @      IF ROW -- 1 CURSOR-IS-DIRTY !
  243.                        ELSE BACK-WRAP THEN ;
  244. : NEXT-LINE ROW @ 15 < IF ROW ++ 1 CURSOR-IS-DIRTY !
  245.                        ELSE FORWARD-WRAP THEN ;
  246. : BEGINNING-OF-LINE 0 COL ! 1 CURSOR-IS-DIRTY ! ;
  247. : END-OF-LINE      C/L 1- COL ! 1 CURSOR-IS-DIRTY ! ;
  248. : EDIT-CR NEXT-LINE BEGINNING-OF-LINE ;
  249. : PREV-CHAR COL @ IF COL -- 1 CURSOR-IS-DIRTY !
  250.                   ELSE END-OF-LINE PREV-LINE
  251.                   THEN ;
  252. : NEXT-CHAR COL @ C/L 1- < IF COL ++ 1 CURSOR-IS-DIRTY !
  253.                            ELSE EDIT-CR
  254.                            THEN ;
  255. -->
  256. ------------------ SCREEN 15 ------------------
  257. ( EDITOR -- SCREEN 6 OF 19 -- MORE LOW-LEVEL )
  258. : THIS-CHAR
  259.   ROW @ EDIT-SCR @ (LINE) DROP COL @ + ;
  260.  
  261. : PUT-CHAR THIS-CHAR C! 1 MUST-UPDATE ! ;
  262.  
  263. : INSERT-CHAR PUT-CHAR NEXT-CHAR ;
  264.  
  265. : SELF-INSERT
  266.   LAST-KEY-STRUCK @ DUP THIS-CHAR C! EMIT
  267.   NEXT-CHAR
  268. ;
  269.  
  270. DECIMAL -->
  271.  
  272.  
  273. ------------------ SCREEN 16 ------------------
  274. ( EDITOR -- SCREEN  7 OF 19 -- DISPLAY STUFF )
  275. HEX
  276. : SHOWSCR         ( N -- SHOWS SCREEN N )
  277.    CLS
  278.    0 10 LOCATE STANDOUT ." SCREEN " DUP . STANDEND
  279.    10 0 DO
  280.         0 I LOCATE
  281.            I OVER .LINE
  282.         LOOP DROP ;
  283.  
  284. : REDRAW EDIT-SCR @ SHOWSCR ;
  285.  
  286. : ?REDRAW
  287.   MUST-UPDATE @ IF REDRAW 0 MUST-UPDATE !
  288.                           1 CURSOR-IS-DIRTY ! THEN ;
  289. DECIMAL -->
  290. ------------------ SCREEN 17 ------------------
  291. ( EDITOR -- SCREEN  8 OF 19 -- EXECUTE-KEY )
  292.  
  293. : EXECUTE-KEY        ( K -- EXECUTE THE KEY )
  294.   WORDSIZE * KEYMAP + @ -DUP IF
  295.                            EXECUTE
  296.                         ELSE
  297.                            SELF-INSERT
  298.                         THEN
  299. ;
  300. : ?PLACE-CURSOR
  301.   CURSOR-IS-DIRTY @ IF
  302.     COL @ ROW @ LOCATE
  303.     0 CURSOR-IS-DIRTY !
  304.   THEN
  305. ;
  306. -->
  307. ------------------ SCREEN 18 ------------------
  308. ( EDITOR -- SCREEN  9 OF 19 -- TOP-LEVEL )
  309. : TOP-LEVEL
  310.   BEGIN
  311.     ?REDRAW ?PLACE-CURSOR ED-KEY EXECUTE-KEY
  312.   AGAIN
  313. ;
  314.  
  315.  
  316. : EDIT
  317.   EDIT-SCR ! CLS
  318.   0 ROW ! 0 COL ! 1 MUST-UPDATE !
  319.   TOP-LEVEL
  320. ;
  321.  
  322.  
  323. -->
  324. ------------------ SCREEN 19 ------------------
  325. ( EDITOR -- SCREEN 10 OF 19 -- HIGH-LEVEL KEY WORDS )
  326.  
  327. : UPDATE-SCR                 ( BOUND TO ^U )
  328.   EDIT-SCR @ B/SCR * DUP B/SCR + SWAP DO
  329.     I BLOCK DROP UPDATE
  330.   LOOP ;
  331.  
  332.  
  333. : NEXT-SCR                   ( ^C and ESC-C )
  334.   EDIT-SCR ++   1 MUST-UPDATE !
  335. ;
  336.  
  337. : PREV-SCR                   ( ^R and ESC-R )
  338.   EDIT-SCR @ 0= IF EDIT-SCR ++ THEN
  339.   EDIT-SCR --   1 MUST-UPDATE ! ;
  340. -->
  341. ------------------ SCREEN 20 ------------------
  342. ( EDITOR -- SCREEN 11 OF 19 -- HIGH-LEVEL )
  343. HEX
  344. : TAB-KEY        ( INCREMENT TO NEXT TAB STOP )
  345.   COL @ 8 + F8 AND DUP C/L < IF COL ! THEN ;
  346.  
  347. DECIMAL
  348.  
  349. : REEDIT         ( RESTART EDITING )
  350.   EDIT-SCR @ EDIT ;
  351.  
  352. : ERRCONV
  353.   ERRBLK @ DUP B/SCR / SWAP B/SCR MOD DUP +
  354.   ERRIN @ C/L @ / + ;
  355. : ERREDIT ERRCONV ROW ! EDIT-SCR ! BEGINNING-OF-LINE
  356.   1 MUST-UPDATE ! CLS TOP-LEVEL ;
  357. -->
  358. ------------------ SCREEN 21 ------------------
  359. ( EDITOR -- SCREEN 12 OF 19 -- )
  360.  
  361. : UPDATE-AND-FLUSH
  362.   UPDATE-SCR FLUSH ;
  363.  
  364. : DEL-TO-END-OF-LINE
  365.   COL @ ROW @ EDIT-SCR @  ( SAVE THESE )
  366.   C/L COL @ DO BL INSERT-CHAR LOOP
  367.   EDIT-SCR ! ROW ! COL !  ( RESTORE SAVED VALUES )
  368. ;
  369.  
  370.  
  371.  
  372.  
  373.  
  374. -->
  375. ------------------ SCREEN 22 ------------------
  376. ( EDITOR -- SCREEN 13 OF 19 -- MORE HIGH-LEVEL )
  377.  
  378. : CLEAR-SCREEN
  379.   EDIT-SCR @ B/SCR * DUP B/SCR + SWAP DO
  380.      I BLOCK B/BUF BLANKS
  381.   LOOP
  382.   1 MUST-UPDATE !
  383. ;
  384.  
  385. : DESCRIBE-BINDINGS     ( SHOWS ALL BINDINGS )
  386.   256 0 DO              ( INTERESTING ONES, ANYWAY )
  387.     I BIND-ADDR @
  388.     -DUP IF CR I ^EMIT SPACE NFA ID. THEN
  389.     ?TERMINAL IF LEAVE THEN
  390.   LOOP CR ;
  391. -->
  392. ------------------ SCREEN 23 ------------------
  393. ( EDITOR -- SCREEN 14 OF 19 -- WORD MOVEMENT )
  394. : NEXT-WORD
  395.   THIS-CHAR C@ BL = IF PREV-CHAR THEN   ( BUG FIX )
  396.   BEGIN NEXT-CHAR THIS-CHAR C@ BL = UNTIL
  397.   BEGIN NEXT-CHAR THIS-CHAR C@ BL <> UNTIL ;
  398.  
  399. : PREV-WORD
  400.   BEGIN PREV-CHAR THIS-CHAR C@ BL <> UNTIL
  401.   BEGIN PREV-CHAR THIS-CHAR C@ BL = UNTIL
  402.   NEXT-CHAR ;
  403.  
  404.  
  405.  
  406.  
  407.  
  408. -->
  409. ------------------ SCREEN 24 ------------------
  410. ( EDITOR -- SCREEN 15 OF 19 -- BUFFER CONTROL )
  411. : TO-BUFFER             ( COPY FROM HERE TO BUFFER )
  412.   EDIT-SCR @ 16 0 DO
  413.     I OVER (LINE) I C/L * SCR-BUFFER + SWAP CMOVE
  414.   LOOP DROP
  415. ;
  416.  
  417. : FROM-BUFFER           ( COPY FROM BUFFER TO HERE )
  418.   EDIT-SCR @ 16 0 DO
  419.     I OVER (LINE) DROP I C/L * SCR-BUFFER + SWAP C/L CMOVE
  420.   LOOP DROP 1 MUST-UPDATE !
  421. ;
  422.  
  423.  
  424.  
  425. -->
  426. ------------------ SCREEN 25 ------------------
  427. ( EDITOR -- SCREEN 16 OF 19 -- MORE BUFFERS )
  428. : SCR-COPY      ( SRC DEST -- COPIES A SCREEN )
  429.   EDIT-SCR @ ROT ROT    ( OLD IS THIRD )
  430.   SWAP EDIT-SCR ! TO-BUFFER     ( OLD IS SECOND/DEST IS FIRST )
  431.   EDIT-SCR ! FROM-BUFFER UPDATE-SCR
  432.   EDIT-SCR !
  433. ;
  434.  
  435. : QUOTE-NEXT
  436.   ED-KEY INSERT-CHAR
  437. ;
  438.  
  439. : EXECUTE-FORTH-LINE
  440.   0 17 LOCATE 27 EMIT 84 EMIT REFORTH
  441.   1 MUST-UPDATE ! TOP-LEVEL ;
  442. -->
  443. ------------------ SCREEN 26 ------------------
  444. ( EDITOR -- SCREEN 17 OF 19 -- )
  445.  
  446.  
  447.  
  448.  
  449.  
  450.  
  451.  
  452.  
  453.  
  454.  
  455.  
  456.  
  457.  
  458.  
  459. -->
  460. ------------------ SCREEN 27 ------------------
  461. ( EDITOR -- SCREEN 18 OF 19 -- INITIALIZE BINDINGS )
  462.  
  463.   ' PREV-LINE CFA 11 (BIND)  ( ^K )
  464.   ' NEXT-LINE CFA 10 (BIND)  ( ^J )
  465.   ' PREV-CHAR CFA  8 (BIND)  ( ^H )
  466.   ' NEXT-CHAR CFA 12 (BIND)  ( ^L )
  467.   ' NEXT-SCR  CFA  3 (BIND)  ( ^C )
  468.   ' PREV-SCR  CFA 18 (BIND)  ( ^R )
  469.   ' EXIT-EDIT CFA 209 (BIND)  ( ESC-Q )
  470.   ' EDIT-CR   CFA 13 (BIND)  ( ^M )
  471.   ' TAB-KEY   CFA  9 (BIND)  ( ^I )
  472.   ' UPDATE-SCR CFA 21 (BIND) ( ^U )
  473.   ' NEXT-WORD CFA  6 (BIND)  ( ^F )
  474.   ' PREV-WORD CFA  1 (BIND)  ( ^A )
  475.   ' UPDATE-AND-FLUSH CFA 198 (BIND) ( ESC-F )
  476. -->
  477. ------------------ SCREEN 28 ------------------
  478. ( EDITOR -- SCREEN 19 OF 19 -- MORE BINDINGS )
  479.  
  480.   ' DEL-TO-END-OF-LINE CFA 25 (BIND)  ( ^Y )
  481.   ' PREV-CHAR CFA 19 (BIND)     ( ^S )
  482.   ' PREV-LINE CFA 5 (BIND)      ( ^E )
  483.   ' NEXT-LINE CFA 24 (BIND)     ( ^X )
  484.   ' NEXT-CHAR CFA 4 (BIND)      ( ^D )
  485.   ' TO-BUFFER CFA 190 (BIND)    ( ESC-> )
  486.   ' FROM-BUFFER CFA 188 (BIND)  ( ESC-< )
  487.   ' NEXT-SCREEN CFA 195 (BIND)  ( ESC-C )
  488.   ' PREV-SCREEN CFA 210 (BIND)  ( ESC-R )
  489.   ' QUOTE-NEXT CFA 16 (BIND)    ( ^P )
  490.   ' EXECUTE-FORTH-LINE CFA 155 (BIND) ( ESC-ESC )
  491.  
  492. CR ." EDITOR READY "
  493. ;S
  494. ------------------ SCREEN 29 ------------------
  495.