fork download
copy 
  1. \ Portable False interpreter in Forth - by Ben Hoyt - 5 February 2000
  2.  
  3. 0 [IF]
  4.  
  5. This is a False interpreter written in pure ANS Forth! See README.md
  6. for more info.
  7.  
  8. Your words are:
  9. FALSE" FALSE-FILE FALSE-BUFFER >FILE FILE> Stack# Return#
  10.  
  11. To interpret a file, push a string (address and count) on the stack
  12. and tell Forth to FALSE-FILE. Alternatively, use FALSE" file". To
  13. interpret a buffer of false source code in memory, give FALSE-BUFFER
  14. the address and length of the buffer and you're away. To exemplify:
  15.  
  16. FALSE" my-false-file.f"  \ interpret this file
  17. S" my-false-file.f" FALSE-FILE  \ ditto
  18. S" 10[$][1-$.]#%" FALSE-BUFFER  \ countdown in False from 9..0
  19.  
  20. To redirect False input, use FILE> ("file-from"). To redirect output,
  21. use >FILE ("to-file"). >FILE or FILE> with a count of zero will
  22. revert to screen output or keyboard input, respectively. By default,
  23. redirection is set to screen output and keyboard input. Every time
  24. you initiate a False interpretation, the file positions of the
  25. I/O files will be rewound to zero. Some examples:
  26.  
  27. S" output" >FILE  S" input" FILE>  \ redirect both output and input
  28. FALSE" my-false-file.f"
  29.  
  30. S" new-out" >FILE  0 0 FILE>  \ redirect output, keyboard input
  31. FALSE" my-false-file.f"
  32.  
  33. S" " >FILE  S" another-input" FILE>  \ screen output, file input
  34. FALSE" my-false-file.f"
  35.  
  36. When the False interpreter is redirected to or from a file, it does
  37. I/O in binary mode, so any CR or LF will get read in or written out
  38. directly. When you are outputting to the screen, this interpreter
  39. will ignore any carriage-returns (char 13) and execute a Forth CR
  40. when it gets a line-feed (char 10). When you are inputting from the
  41. keyboard, this interpreter will return a line-feed when you press
  42. "Enter" (ie., when KEY gives char 13), and will return -1 when you
  43. press Control-Z (end of file, see below).
  44.  
  45. You can also set False's data and return stack sizes by changing the
  46. VALUEs Stack# and Return#. Just set them to a given size in False
  47. "cells". Each data stack entry requires two Forth CELLs and each
  48. return stack entry one Forth CELL of ALLOCATEd memory. So, for a small
  49. stack, use something like:
  50.  
  51. 100 TO Stack#  50 TO Return#  \ 100 item data stack, 50 item return
  52.  
  53. This program was written to be fully ANS Standard, and I hope it lives
  54. up to that. It requires a 32 bit Forth system (I think only because
  55. False is 32 bit -- I believe this compiles on a 16 bit system quite
  56. well). I use words from the following wordlists:
  57.  
  58. CORE CORE-EXT FILE FILE-EXT MEMORY EXCEPTION SEARCH-ORDER TOOLS-EXT
  59.  
  60. One could easily remove use of the FILE-EXT MEMORY SEARCH-ORDER and
  61. TOOLS-EXT wordlists. I think TOOLS-EXT is only used for this extended
  62. comment, however. :-)
  63.  
  64. Note that I use Control-Z (character 26, hex 1A) when the False
  65. interpreter is receiving keyboard characters to denote end-of-file.
  66. Most Forths give character 26 when you press Control-Z. This is
  67. irrelevant in file input mode anyway.
  68.  
  69. [THEN]
  70.  
  71.  
  72. DECIMAL
  73.  
  74. MARKER UnFalse
  75.  
  76. 1000 VALUE Stack#  \ data and return stack sizes, can be changed
  77. 1000 VALUE Return#
  78.  
  79. WORDLIST CONSTANT FalseWords  \ all internal False interpreter words
  80. GET-ORDER FalseWords SWAP 1+ SET-ORDER  \ use FalseWords
  81. GET-CURRENT  \ "previous current" on stack
  82. DEFINITIONS  \ compile into FalseWords
  83.  
  84. 0 CONSTANT =Num  \ False data type identifiers
  85. 1 CONSTANT =Func
  86. 2 CONSTANT =Addr
  87. 3 CONSTANT =Uninit
  88.  
  89. : PLACE  ( a u dest -- )  \ place counted string a u at dest
  90.   2DUP 2>R  CHAR+ SWAP CHARS MOVE  2R> C! ;
  91.  
  92. : STRING,  ( a u -- )  \ reserve space for and store string
  93.   HERE  OVER 1+ CHARS ALLOT  PLACE ;
  94.  
  95. : STR  ( "<ch> ccc<ch>" -- cstr )  \ parse, reserve and return string
  96.   HERE  BL PARSE DROP C@ PARSE  STRING, ;
  97.  
  98. \ List of error messages and types
  99.  
  100. STR | char expected|
  101. STR | return stack underflow|
  102. STR | return stack overflow|
  103. STR | unbalanced '['|
  104. STR | unbalanced '"'|
  105. STR | unbalanced '{'|
  106. STR | inline assembly unavailable|
  107. STR | unknown symbol|
  108. STR | stack not empty at program exit|
  109. STR | type conflict|
  110. STR | data stack underflow|
  111. STR | data stack overflow|
  112. STR | source too large|  \ errors 1 2 and 3 are unused
  113. STR | could not open source file|
  114. STR | no arguments|
  115.  
  116. CREATE ErrorStrs  \ error messages (15 of them)
  117.   , , , , ,  , , , , ,  , , , , ,
  118.  
  119. STR | unexpected|
  120. STR | uninitialised|
  121. STR | address|
  122. STR | function|
  123. STR | number|
  124.  
  125. CREATE TypeStrs  \ data types (5 of them)
  126.   , , , , ,
  127.  
  128. : TypeTYPE  ( type -- )  \ display type string
  129.   DUP 3 U> IF  DROP 4  THEN  \ make sure it's in range
  130.   CELLS TypeStrs + @  COUNT TYPE ;  \ display
  131.  
  132. \ Input/output and redirection
  133.  
  134. 0 VALUE InFile  0 VALUE OutFile  \ in and out file-ids
  135. CREATE CharBuf  0 C,  \ temp storage for cEmit
  136.  
  137. : Putch  ( char -- )  \ write char to False output
  138.   OutFile IF
  139.     CharBuf C!  CharBuf 1 OutFile WRITE-FILE THROW
  140.   ELSE
  141.     DUP 10 = IF  CR  ELSE  \ do a CR if line feed char
  142.     DUP 13 <> IF  DUP EMIT  THEN THEN  DROP  \ ignore CRs
  143.   THEN ;
  144.  
  145. : Puts  ( a u -- )  \ write string to False output
  146.   OVER + SWAP ?DO  I C@ Putch  LOOP ;
  147.  
  148. : Getch  ( -- char )  \ read char from False input
  149.   InFile IF
  150.     CharBuf 1 InFile READ-FILE THROW
  151.     IF  CharBuf C@  ELSE  -1  THEN  \ char -1 means end-of-file
  152.   ELSE
  153.     KEY  DUP 13 = IF  CR  DROP 10  \ replace CR with LF
  154.     ELSE  DUP EMIT  DUP 26 = IF  DROP -1  THEN  THEN
  155.   THEN ;
  156.  
  157. \ Source buffer stuff
  158.  
  159. 0 VALUE Src  0 VALUE Src#  \ source buffer pointer
  160. VARIABLE p  \ pointer into source buffer
  161.  
  162. : SrcEnd?  ( -- flag )  \ true if end of source buffer
  163.   p @  Src Src# CHARS +  U< 0= ;
  164.  
  165. : SrcChar  ( -- char )  \ grab char from source, don't move pointer
  166.   p @ c@ ;
  167.  
  168. : SrcInc  ( -- )  \ move source pointer along a char
  169.   1 CHARS p +!  ;
  170.  
  171. : NextChar  ( -- char )  \ grab next char from source buffer
  172.   SrcChar SrcInc ;
  173.  
  174. \ False stack manipulation
  175.  
  176. 0 VALUE StackB  0 VALUE StackE  \ data stack beginning and end
  177. 0 VALUE ReturnB  0 VALUE ReturnE  \ return stack
  178. VARIABLE s  VARIABLE r  \ data and return stack pointers
  179.  
  180. VARIABLE Expected  VARIABLE Received  \ expected and received types
  181. VARIABLE Debugging  \ debugging flag (stack dump etc)
  182.  
  183. : Push  ( x type -- )  \ push x with type
  184.   s @ 2 CELLS -  DUP StackB U< 4 AND THROW  \ overflow?
  185.   DUP s !  2! ;  \ type is on top
  186.  
  187. : Popt  ( -- x type  )  \ pop x and type, no check
  188.   s @ 2 CELLS +  DUP StackE U> 5 AND THROW  \ underflow?
  189.   s @ 2@  ROT s ! ;  \ fetch and set new stack pointer
  190.  
  191. : Pop  ( type -- x )  \ pop x, check type
  192.   DUP Expected !  Popt  Dup Received !  \ save types for errors
  193.   ROT <> 6 AND THROW ;  \ check for type conflict
  194.  
  195. : nPush  ( n -- )  \ push number
  196.   =Num Push ;
  197.  
  198. : nPop  ( -- n )  \ pop number
  199.   =Num Pop ;
  200.  
  201. : rPush  ( x -- )  \ push x to return stack
  202.   r @ 1 CELLS -  DUP ReturnB U< 13 AND THROW
  203.   DUP r !  ! ;
  204.  
  205. : rPop  ( -- x )  \ pop x from return stack
  206.   r @ CELL+  DUP ReturnE U> 14 AND THROW
  207.   r @ @  SWAP r ! ;
  208.  
  209. : Func  ( func -- )  \ enter lambda function
  210.   p @ rPush  p ! ;
  211.  
  212. \ Variable space handling
  213.  
  214. 0 VALUE Vars  \ variable space
  215.  
  216. : Var?  ( char -- t=var )  \ true if char is variable a..z
  217.   [CHAR] a - 26 U< ;
  218.  
  219. : Var!  ( x type vaddr -- )  \ store x and type in variable
  220.   2* CELLS Vars + 2! ;
  221.  
  222. : Var@  ( vaddr -- x type )  \ fetch x and type from variable
  223.   2* CELLS Vars + 2@ ;
  224.  
  225. : Var  ( 0..25 -- )  \ push False variable "address"
  226.   =Addr Push ;
  227.  
  228. : MakeVars  ( -- xt-z .. xt-a )  \ make words to do each variable
  229.   0 25 DO
  230.     :NONAME  I POSTPONE LITERAL POSTPONE Var POSTPONE ;
  231.   -1 +LOOP ;
  232.  
  233. \ Number conversion
  234.  
  235. : (.)  ( n -- a u )  \ return string to display n
  236.   DUP ABS 0  <# #S ROT SIGN #> ;  \ False . will use Forth's BASE
  237.  
  238. : Number  ( 0..9 -- )  \ parse and push False number
  239.   BEGIN
  240.     SrcEnd? 7 AND THROW  \ finished source but stack not empty
  241.     SrcChar  [CHAR] 0 -  DUP 10 U< WHILE  \ go till non-digit
  242.     SrcInc  SWAP 10 *  +  \ convert and accumulate
  243.   REPEAT  DROP nPush ;  \ push it to False stack
  244.  
  245. : MakeNumbers  ( -- xt-9 .. xt-0 )  \ make words to do each digit
  246.   0 9 DO
  247.     :NONAME  I POSTPONE LITERAL POSTPONE Number POSTPONE ;
  248.   -1 +LOOP ;
  249.  
  250. \ Some False operator stuff
  251.  
  252. : BinaryOp  ( xt -- )  \ execute binary operator xt on False stack
  253.   nPop nPop SWAP  ROT EXECUTE nPush ;  \ False: n1 n2 -- n3
  254.  
  255. : LAND  ( n1 n2 -- flag )  \ true if n1 and n2 are nonzero
  256.   0<> SWAP 0<> AND ;  \ like C's logical and operator &&
  257.  
  258. : LOR  ( n1 n2 -- flag )  \ true if n1 or n2 is nonzero
  259.   0<> SWAP 0<> OR ;  \ like C's logical or operator ||
  260.  
  261. \ Words for all the False symbols, these don't touch the Forth stack
  262.  
  263. : cWhite    ;
  264. : cBad      8 THROW ;
  265. : cApply    =Func Pop Func ;
  266. : cDup      Popt 2DUP Push Push ;
  267. : cDrop     Popt 2DROP ;
  268. : cAnd      ['] LAND BinaryOp ;
  269. : cChar     SrcEnd? 15 AND THROW  NextChar nPush ;
  270. : cStar     ['] * BinaryOp ;
  271. : cPlus     ['] + BinaryOp ;
  272. : cMinus    ['] - BinaryOp ;
  273. : cSlash    ['] / BinaryOp ;
  274. : cStore    =Addr Pop Popt  ROT Var! ;
  275. : cFetch    =Addr Pop Var@  Push ;
  276. : cEquals   Popt Pop = nPush ;  \ equals works with any one type
  277. : cGreater  ['] > BinaryOp ;  \ greater only works with numbers
  278. : cIf       =Func Pop nPop IF  Func  ELSE DROP THEN ;
  279. : cRot      Popt Popt Popt  2ROT 2ROT  Push Push Push ;
  280. : cDebug    Debugging @ 0= Debugging ! ;
  281. : cSwap     Popt Popt  2SWAP  Push Push ;
  282. : cNegate   nPop NEGATE nPush ;
  283. : cAsm      9 THROW ;
  284. : cOr       ['] LOR BinaryOp ;
  285. : cNot      nPop INVERT nPush ;
  286. : cEmit     nPop Putch ;
  287. : cDot      nPop (.) Puts ;
  288. : cRead     Getch nPush ;
  289.  
  290. : cFlush  \ flush I/O (only output for us)
  291.   OutFile IF  \ truncate to current file position and flush
  292.     OutFile FILE-POSITION THROW  OutFile RESIZE-FILE THROW
  293.     OutFile FLUSH-FILE THROW
  294.   THEN ;
  295.  
  296. : cString  \ output all chars till ending quote
  297.   BEGIN
  298.     SrcEnd? 11 AND THROW  NextChar DUP [CHAR] " <> WHILE
  299.     Putch
  300.   REPEAT  DROP ;
  301.  
  302. : cPick  \ pick, zero based, 0O is $ (ie., 0 PICK is DUP)
  303.   nPop 2* CELLS s @ +
  304.   DUP s @ StackE WITHIN 0=  5 AND THROW  \ bounds check
  305.   2@ Push ;  \ push value and type
  306.  
  307. : cComment  \ ignore all chars till ending brace, non-nesting
  308.   BEGIN  SrcEnd? 10 AND THROW  NextChar  [CHAR] } = UNTIL ;
  309.  
  310. : cWhile  \ False return stack: if-func do-func p-afterwhile 0
  311.   =Func Pop =Func Pop  TUCK rPush rPush  Func  0 rPush ;
  312.  
  313. : cLambda  \ parse nested lambdas, return function
  314.   p @ =Func Push  1 BEGIN  \ nest depth on stack
  315.     SrcEnd? 12 AND THROW  DUP 0> WHILE
  316.     NextChar CASE
  317.       [CHAR] ' OF  \ skip char after ' (in case it's [ or " etc)
  318.         SrcEnd? 15 AND THROW  NextChar DROP  ENDOF
  319.       [CHAR] ] OF  1-  ENDOF  \ nest into lambda
  320.       [CHAR] [ OF  1+  ENDOF  \ unnest lambda
  321.       [CHAR] { OF  cComment  ENDOF  \ skip comments
  322.       [CHAR] " OF  \ skip strings
  323.         BEGIN  SrcEnd? 11 AND THROW  NextChar [CHAR] " = UNTIL  ENDOF
  324.       \ ignore anything else
  325.     ENDCASE
  326.   REPEAT  DROP ;
  327.  
  328. : cAdbmal  \ end lambda function
  329.   rPop CASE
  330.     0 OF  \ just finished comparison part of while construct
  331.       rPop p !  \ set p to just after while #
  332.       nPop IF  \ flag<>0, start executing "do" lambda
  333.         rPop DUP rPush  Func  1 rPush
  334.       ELSE  rPop rPop 2DROP  THEN  ENDOF  \ flag=0, skip to after #
  335.     1 OF  \ just finished function part of while construct
  336.       rPop p !  rPop rPop TUCK rPush rPush  Func  0 rPush  ENDOF
  337.     DUP p !  \ end lambda function "normally"
  338.   ENDCASE ;
  339.  
  340. \ Create the symbol jump table
  341.  
  342. : TICKS-OF  ( n "word" -- )  \ comma n xt's of word
  343.   '  SWAP 0 ?DO  DUP ,  LOOP  DROP ;
  344.  
  345. : TICKS  ( n "words" -- )  \ tick and comma n words
  346.   0 ?DO  ' ,  LOOP ;
  347.  
  348. MakeVars  MakeNumbers  \ 36 xt's on stack for digits and variables
  349.  
  350. CREATE Jumper  \ 256-char jump table for False symbols
  351.   32 TICKS-OF cWhite  \ treat all low ASCII chars as whitespace
  352.   \       BL     !      "       #      $    %     &    '
  353.   8 TICKS cWhite cApply cString cWhile cDup cDrop cAnd cChar
  354.   \       (    )    *     +     ,     -      .    /
  355.   8 TICKS cBad cBad cStar cPlus cEmit cMinus cDot cSlash
  356.   \ 0 1 2 3 4 5 6 7 8 9          :      ;      <    =       >        ?
  357.     , , , , , , , , , ,  6 TICKS cStore cFetch cBad cEquals cGreater cIf
  358.   \       @    A    B      C    D       E through N       O
  359.   5 TICKS cRot cBad cFlush cBad cDebug  10 TICKS-OF cBad  1 TICKS cPick
  360.   \ P through Z             [       \     ]       ^     _
  361.   11 TICKS-OF cBad  5 TICKS cLambda cSwap cAdbmal cRead cNegate
  362.   \       `     a b c d e f g h i j  k l m n o p q r s t  u v w x y z
  363.   1 TICKS cAsm  , , , , , , , , , ,  , , , , , , , , , ,  , , , , , ,
  364.   \       {        |   }    ~
  365.   5 TICKS cComment cOr cBad cNot cBad
  366.   \ high ASCII chars begin here, all bad except the Amiga flush and pick
  367.   \                         ß $DF                             ø $F8
  368.   95 TICKS-OF cBad  1 TICKS cFlush  24 TICKS-OF cBad  1 TICKS cPick
  369.   7 TICKS-OF cBad
  370.  
  371. : Jump  ( char -- xt )  \ get the jump for symbol ch
  372.   CELLS Jumper + @ ;
  373.  
  374. \ The False debugger
  375.  
  376. : Desplay  ( x type -- )  \ show item for debugger
  377.   CASE
  378.     =Num OF  .  ENDOF
  379.     =Func OF  ." p="  Src - 1 CHARS / .  ENDOF
  380.     =Addr OF  [CHAR] a + EMIT  SPACE  ENDOF
  381.     NIP DUP TypeTYPE  SPACE
  382.   ENDCASE ;
  383.  
  384. : Debugger  ( -- )  \ show debugging info: [ stack ... top | nextsymbol ]
  385.   SrcEnd? 0= IF  \ if not at end of source
  386.     SrcChar Jump  ['] cWhite <> IF  \ only if next symbol is non-white
  387.       ." [ "  \ display top (max ten) stack items
  388.       s @ 20 CELLS +  DUP StackE U> IF  DROP StackE  THEN
  389.       BEGIN  DUP s @ U> WHILE  2 CELLS -  DUP 2@ Desplay  REPEAT
  390.       DROP  ." | "  SrcChar EMIT  ."  ] "  \ show next symbol
  391.     THEN
  392.   THEN ;
  393.  
  394. \ The False and deceitful interpreter
  395.  
  396. : Falsehood  ( -- )  \ interpret False characters
  397.   BEGIN
  398.     SrcEnd? 100 AND THROW
  399.     NextChar  Jump EXECUTE  \ get char and go to its symbol
  400.     Debugging @ IF  Debugger  THEN
  401.   AGAIN ;
  402.  
  403. : Deceit  ( n -- )  \ process a False deception (error)
  404.   DUP 100 =  s @ StackE <>  AND IF  DROP 7  THEN  \ stack not empty at end
  405.   DUP 100 <> IF  \ 100 means normal end, else error
  406.     DUP DUP 0< AND THROW  \ reTHROW internal errors
  407.     CR  ." Error "  DUP .  ." at char "
  408.     p @ Src - 1 CHARS /  0 .R  ." : "
  409.     DUP 1 16 WITHIN IF  \ in the range of our errors?
  410.       DUP 1- CELLS ErrorStrs + @  COUNT TYPE  SPACE  \ display error msg
  411.       DUP 6 = IF  \ type conflict, show types involved
  412.         CR ." Expecting "  Expected @ TypeTYPE
  413.         ."  and received " Received @ TypeTYPE  SPACE
  414.       THEN
  415.     ELSE  ." unexpected error"  THEN  \ some wacko error!
  416.   THEN  DROP ;
  417.  
  418. : Buffer  ( -- )  \ interpret the False buffer
  419.   Stack# 2* CELLS ALLOCATE THROW  TO StackB  \ allocate False data stack
  420.   StackB Stack# 2* CELLS + TO StackE  StackE s !
  421.   Return# CELLS ALLOCATE THROW  TO ReturnB  \ allocate False return stack
  422.   ReturnB Return# CELLS + TO ReturnE  ReturnE r !
  423.   52 CELLS ALLOCATE THROW  TO Vars  \ allocate 26 variables/types
  424.   26 0 DO  0 =Uninit I Var!  LOOP  \ undefine variables
  425.   Src p !  \ init source pointer
  426.   -1 Expected !  -1 Received !  \ unexpected types
  427.   FALSE Debugging !  \ not debugging by default
  428.   OutFile IF  0. OutFile REPOSITION-FILE THROW  THEN  \ rewind I/O files
  429.   InFile IF  0. InFile REPOSITION-FILE THROW  THEN
  430.   ['] Falsehood CATCH  \ catch the interpreter
  431.   Vars FREE THROW  StackB FREE THROW  ReturnB FREE THROW  \ free memory
  432.   Deceit  cFlush ;  \ process False deceptions, flush output
  433.  
  434. SET-CURRENT  \ public words in previous current
  435.  
  436. : >FILE  ( a u -- )  \ write False output to file named a u
  437.   OutFile ?DUP IF  CLOSE-FILE THROW  THEN
  438.   DUP 0= IF  2DROP 0  \ if u=0 then write to screen
  439.   ELSE  W/O BIN CREATE-FILE THROW  THEN TO OutFile ;
  440.  
  441. : FILE>  ( a u -- )  \ read False input from file named a u
  442.   InFile ?DUP IF  CLOSE-FILE THROW  THEN
  443.   DUP 0= IF  2DROP 0  \ if u=0 then read from keyboard
  444.   ELSE  R/O BIN OPEN-FILE THROW  THEN TO InFile ;
  445.  
  446. : FALSE-BUFFER  ( a u -- )  \ interpret buffer of False
  447.   TO Src# TO Src  Buffer ;
  448.  
  449. : FALSE-FILE  ( a u -- )  \ interpret source file named by string a u
  450.   R/O BIN OPEN-FILE THROW  >R  \ open in binary mode
  451.   R@ FILE-SIZE THROW DROP  TO Src#  \ get file size
  452.   Src# CHARS ALLOCATE THROW TO Src  \ allocate buffer for source
  453.   Src Src# R@ READ-FILE THROW  Src# <> -39 AND THROW  \ read in whole file
  454.   R> CLOSE-FILE THROW  \ close file
  455.   Buffer  \ interpret buffer
  456.   Src FREE THROW ;  \ free source buffer
  457.  
  458. : FALSE"  ( "filename<quote>" -- )  \ interpret False file
  459.   [CHAR] " PARSE FALSE-FILE ;
  460.  
  461. PREVIOUS  \ remove FalseWords from search order
  462.  
  463. S" [$$!]$!" FALSE-BUFFER
Success #stdin #stdout 0.01s 5308KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Error 4 at char 3: data stack overflow
https://ideone.com/gTxwcv
language:
Forth (gforth 0.7.3)
created:
1 day ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!