home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / tile-forth-2.1-bin.lha / lib / tile-forth / parser.f83 < prev    next >
Text File  |  1996-10-12  |  12KB  |  422 lines

  1. \
  2. \  TOP DOWN PARSER DEFINITIONS
  3. \
  4. \  Copyright (C) 1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 12 February 1990
  15. \
  16. \  Last updated on: 21 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, compiler, structures, blocks, internals
  20. \
  21. \  Description:
  22. \       Top down parser virtual machine instructions.
  23. \
  24. \  Copying:
  25. \       This program is free software; you can redistribute it and\or modify
  26. \       it under the terms of the GNU General Public License as published by
  27. \       the Free Software Foundation; either version 1, or (at your option)
  28. \       any later version.
  29. \
  30. \       This program is distributed in the hope that it will be useful,
  31. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  32. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  33. \       GNU General Public License for more details.
  34. \
  35. \       You should have received a copy of the GNU General Public License
  36. \       along with this program; see the file COPYING.  If not, write to
  37. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  38.  
  39. .( Loading Parser definitions...) cr
  40.  
  41. #include internals.f83
  42. #include structures.f83
  43. #include blocks.f83
  44.  
  45. vocabulary parser ( -- )
  46.  
  47. compiler blocks structures parser definitions
  48.  
  49. \ Grammer symbol structure
  50.  
  51. struct.type symbol ( -- ) 
  52.   ptr +entry ( symbol -- addr) private
  53.   ptr +syntax ( symbol -- addr) private
  54.   ptr +primary ( symbol -- addr) private
  55. struct.init ( symbol -- )
  56.   last over +entry !            ( Assign pointer back to entry)
  57.   nil over +syntax !            ( Initiate syntax pointer)
  58.   nil swap +primary !            ( Initiate primary pointer)
  59. struct.end
  60.  
  61. \ Grammer production structure
  62.  
  63. struct.type rule ( -- ) private
  64.   ptr +next ( rule -- addr) private
  65.   ptr +rule ( rule -- addr) private
  66. struct.end
  67.  
  68. \ Scanner buffer and break function pointer
  69.  
  70. variable buffer ( -- addr)
  71. variable >buffer ( -- addr)
  72. variable >break ( -- addr)
  73. variable >skip ( -- addr)
  74.  
  75. : skip-white-space ( addr1 -- addr2)
  76.   begin                    ( Skip blanks before symbol)
  77.     dup c@ dup                ( Fetch the character)
  78.     32 > not swap            ( Check if it is not a character)
  79.     0= not and                ( Check if it is not null)
  80.   while
  81.     1+                    ( Step to next character)
  82.   repeat
  83.  
  84. ' skip-white-space >skip !        ( Assign initiate skip function)
  85.  
  86. : break-on-special ( addr1 -- bool)
  87.   c@                    ( Fetch next character)
  88.   dup ascii a ascii z ?within        ( Check if a lowercase letter)
  89.   if drop false                ( Return false)
  90.   else
  91.     dup ascii A ascii Z ?within        ( Check if a uppercase letter)
  92.     if drop false            ( Return false)
  93.     else
  94.       ascii 0 ascii 9 ?within not    ( Check if not a digit character)
  95.     then
  96.   then
  97.  
  98. : break-on-white-space ( addr -- bool)
  99.   c@ 32 > not                 ( Forth word break function)
  100.  
  101. ' break-on-special >break !        ( Assign initiate break function)
  102.  
  103. : scan ( -- addr n)
  104.   >buffer @                ( Start scanning in input buffer)
  105.   >skip @ execute            ( Perform skip function)
  106.   dup                    ( Save pointer to beginning)
  107.   dup >break @ execute            ( Use break function)
  108.   if dup c@                ( Check for a single break character)
  109.     if 1+ then                ( Increment to capture)
  110.   else
  111.     begin
  112.       1+                ( Increment to next character)
  113.       dup >break @ execute        ( Use break function)
  114.     until                ( Time to stop scanning)
  115.   then
  116.   dup >buffer !                ( Save pointer to next character)
  117.   over -                ( Calculate number of characters)
  118. ;
  119.  
  120. \ String matching function
  121.  
  122. #ifundef -match
  123.  
  124. : -match ( addr1 addr2 n -- bool)
  125.   ?dup                    ( Check for non zero length)
  126.   if >r                    ( Save length)
  127.     begin
  128.       over c@ over c@ =            ( Compare two character)
  129.     while
  130.       1+ swap 1+ swap            ( Move to the next characters)
  131.       r> 1- ?dup            ( Decrement length and check)
  132.       if >r                ( Save length)
  133.       else
  134.     drop drop false exit        ( Drop pointers and return equal)
  135.       then
  136.     repeat
  137.     r> drop                ( Drop length)
  138.   then
  139.   drop drop                ( Drop pointers)
  140.   true                    ( And return not equal)
  141. ; private
  142.  
  143. #then
  144.  
  145.  
  146. \ The result of a parse: list of semantic actions
  147.  
  148. 128 constant semantics-size ( -- num) private
  149. create semantics ( -- addr) private semantics-size cells allot
  150. variable >semantics ( -- addr) private
  151.  
  152. : semantic, ( addr -- )
  153.   >semantics @ !            ( Append to list of semantics)
  154.   cell >semantics +!            ( Point to next free place in list)
  155. ;
  156.  
  157. : bind ( addr -- )
  158.   ['] (literal) semantic,        ( Generate a literal for the parameter)
  159.   semantic,                ( Passed at semantic execution time)
  160. ;
  161.  
  162. \ Parser environment for seize, release and backtrack
  163.  
  164. : seize ( rule -- rule x y rule)
  165.   dup >r                ( Copy rule parameter)
  166.   >buffer @ >semantics @        ( Build backtrack environment)
  167.   r>                    ( Return copy of rule)
  168. ; private
  169.  
  170. : release ( rule x y -- )
  171.   drop drop drop            ( Drop environment frame)
  172. ; private
  173.  
  174. : backtrack ( x y  -- )
  175.   >semantics ! >buffer !        ( Restore environment frame)
  176. ; private
  177.  
  178. \ Utility function for Parser Virtual Machine Instructions
  179.  
  180. : rule ( rule -- bool)
  181.   +rule call                ( Execute rule function)
  182. ; private
  183.  
  184. : syntax ( symbol -- bool)
  185.   +syntax @ ?dup            ( Fetch syntax definition)
  186.   if                    ( If available then for all rules)
  187.     begin
  188.       ?dup                ( For all rules)
  189.     while
  190.       seize rule            ( Seize the environment. Check rule)
  191.       if release true exit then        ( If accepted then return accept)
  192.       backtrack                ( Else backtrack to latest environment)
  193.       +next @                ( And try next rule)
  194.     repeat
  195.   then
  196.   false                    ( Return reject)
  197. ; private
  198.  
  199. : primary ( symbol -- bool)
  200.   +primary @ ?dup            ( Fetch primary definition )
  201.   if call                ( If available call function)
  202.   else
  203.     false                ( Else return reject)
  204.   then
  205. ; private
  206.  
  207. \ Parser Virtual Machine Instructions
  208.  
  209. : terminal ( symbol -- [] or [false])
  210.   +entry @ +name @            ( Access name string for symbol)
  211.   scan -match                ( Scan next token and match)
  212.   if r> drop false then            ( If not equal then reject)
  213. ;
  214.  
  215. : non-terminal ( symbol -- [] or [false])
  216.   dup syntax                ( Try syntax definition)
  217.   if drop true                ( If accepted continue)
  218.   else
  219.     primary                ( If rejected try primary function)
  220.   then
  221.   not
  222.   if r> drop false then            ( If not accepted then reject)
  223. ;
  224.  
  225. : zero-or-one ( symbol -- )
  226.   dup syntax                ( Try syntax definition)
  227.   if drop                ( Drop symbol parameter)
  228.   else
  229.     primary drop            ( Try primary definition)
  230.   then                    ( Always continue)
  231. ;
  232.  
  233. : zero-or-more ( symbol -- )
  234.   begin
  235.     dup syntax                ( Try syntax definition)
  236.     if true                ( One more time)
  237.     else
  238.       dup primary            ( Try primary definition)
  239.     then
  240.     not                    ( Check for more)
  241.   until
  242.   drop                    ( Drop symbol parameter and continue)
  243. ;
  244.  
  245. : semantic ( -- true)
  246.   r> @ semantic, true            ( Append semantic function and accept)
  247. ;
  248.  
  249. : no-semantic ( -- true)
  250.   r> drop true                ( Always return accepted)
  251. ;
  252.  
  253. \ Low Level Parser Interaction
  254.  
  255. forth
  256.  
  257. : parse ( symbol -- [semantics] or [false])
  258.   buffer @ >buffer !            ( Initiate buffer pointer)
  259.   semantics >semantics !        ( And list of semantics)
  260.   syntax                ( Try syntax definition)
  261.   if ['] exit semantic,            ( If accepted the append exit)
  262.     semantics                ( And return the list of semantics)
  263.   else
  264.     false                ( Return not parsed)
  265.   then
  266. ;
  267.  
  268. : parse" ( symbol -- )
  269.   ascii " word buffer !            ( Parse the following string)
  270.   parse ?dup                ( Use the parameter symbol syntax)
  271.   if call                ( Call the semantic actions if parsed)
  272.   else
  273.     ." No parse" cr            ( Else no parse message)
  274.   then
  275. ; execution
  276.  
  277. \ High Level Interaction Top Loop
  278.  
  279. 256 constant interact-buffer-size ( -- num) private
  280. create interact-buffer ( -- addr) private interact-buffer-size allot
  281.  
  282. : interact ( symbol -- )
  283.   interact-buffer buffer !        ( Assign input buffer)
  284.   begin
  285.     interact-buffer            ( Input buffer for interact)
  286.     interact-buffer-size expect        ( Read a line to input buffer)
  287.     span @                ( Check for empty lines)
  288.     if 0 interact-buffer span @ + c!    ( Null terminal the line)
  289.       dup parse ?dup            ( Try parsing it)
  290.       if call                ( If parsed the call semantic actions)
  291.       else
  292.     buffer @ >buffer !        ( Rescan for forth to level loop)
  293.     ['] forth +name @        ( Use forth name field)
  294.     scan -match            ( Scan first token and match)
  295.     if ." No parse" cr        ( Else no parse possible)
  296.     else
  297.       drop exit            ( Drop parameter symbol and exit)
  298.     then
  299.       then
  300.     then
  301.   again
  302. ;
  303.  
  304. \ Syntax for definition of primary functions and syntax rules
  305.  
  306. : primary ( symbol -- )
  307.   here swap +primary !            ( Add primary function to symbol)
  308.   ]                    ( Start compiling primary function)
  309. ;
  310.  
  311. : end.primary ( -- )
  312.   [compile] ;                ( Stop compiling primary function)
  313. ; immediate compilation
  314.  
  315. : syntax ( symbol -- )
  316.   dup +syntax @ ?dup            ( Check if the symbol has syntax)
  317.   if swap drop                ( Append last in list of rules)
  318.     begin
  319.       dup +next @ ?dup            ( Check if this is the last rule)
  320.     while                ( If not then step to next rule)
  321.       swap drop
  322.     repeat     
  323.     here swap +next !            ( Link into list of rules)
  324.   else
  325.     here swap +syntax !            ( Add as first rule)
  326.   then
  327.   nil , ]                ( And start compiling the rule)
  328. ;
  329.  
  330. : end.syntax ( -- )
  331.   [compile] [                ( Stop compiling the rule)
  332. ; immediate compilation
  333.  
  334. \ Basic primary functions: empty, eoln, number och entry
  335.  
  336. parser
  337.  
  338. symbol empty ( -- symbol)
  339. symbol eoln ( -- symbol)
  340. symbol number ( -- symbol)
  341. symbol identifier ( -- symbol)
  342. symbol entry ( -- symbol)
  343.  
  344. empty primary ( -- true)
  345.   true                    ( Always accept)
  346. end.primary
  347.  
  348. eoln primary ( -- bool)
  349.   scan swap drop 0=            ( Scan next token and check length)
  350. end.primary
  351.  
  352. number primary ( -- bool)
  353.   scan                    ( Scan next token and check length)
  354.   if dup 0 swap                ( Convert to a number and check)
  355.     convert rot =
  356.     if drop false            ( If not a number reject)
  357.     else
  358.       bind true                ( Else bind the number and accept)
  359.     then
  360.   else
  361.     drop false                ( If no token scanned the reject)
  362.   then
  363. end.primary
  364.   
  365. identifier primary ( -- bool)
  366.   scan ?dup                ( Scan next token and check length)
  367.   if over c@ dup            ( Fetch first character and check)
  368.      ascii a ascii z ?within swap    ( A lowercase letter or)
  369.      ascii A ascii Z ?within or        ( A uppercase letter )
  370.      if swap bind bind true        ( Bind identifier string and accept)
  371.      else
  372.        drop drop false            ( Reject this parse)
  373.      then
  374.    else
  375.      drop false                ( Reject this parse. No more input)
  376.    then
  377. end.primary
  378.    
  379. parser
  380.  
  381. \ Token buffer for vocabulary lookup
  382.  
  383. 128 constant token-size ( -- num) private
  384. create token ( -- addr) token-size allot private
  385.  
  386. entry primary ( -- bool)
  387.   scan ?dup                ( Scan next token and check length)
  388.   if dup >r                ( Save length of scan string)
  389.     token swap cmove            ( Assign token string and)
  390.     0 token r> + c!            ( terminate with a null character)
  391.     token find                ( Try to locate the symbol)
  392.     if dup +code @ VOCABULARY =        ( Check if the entry is a vocabulary)
  393.       if scan 1 =            ( Scan next token and check length)
  394.     if c@ ascii : =            ( Check first character as colon)
  395.       if >break @            ( Fetch old break function)
  396.         ['] break-on-white-space    ( Use forth word break function)
  397.         >break !            ( as the scanner break function)
  398.         scan             ( Scan again for token)
  399.         rot >break !        ( Restore old break function)
  400.         ?dup            ( Check length)
  401.         if dup >r            ( Pack as a null terminated string)
  402.           token swap cmove        ( Move string)
  403.           0 token r> + c!        ( Pad with null character)
  404.           token swap lookup        ( Look for the token in the vocabulary)
  405.           if bind true exit then    ( If found then bind, accept and exit)
  406.         then
  407.         drop            ( Drop string parameter)
  408.       then
  409.     then
  410.       else
  411.     bind true exit            ( Bind symbol and accept)
  412.       then
  413.     then
  414.   then
  415.   drop false                ( If no token scanned the reject)
  416. end.primary
  417.   
  418. forth only
  419.