Geek Gadgets 1/ADE-1.bin/ade-dist/tile-forth-2.1-bin.lha/lib/tile-forth/parser.f83

Text File | 1996-10-12 | 12KB | 422 lines

\
\  TOP DOWN PARSER DEFINITIONS
\
\  Copyright (C) 1990 by Mikael R.K. Patel
\
\  Computer Aided Design Laboratory (CADLAB)
\  Department of Computer and Information Science
\  Linkoping University
\  S-581 83 LINKOPING
\  SWEDEN
\
\  Email: [e-mail]
\
\  Started on: 12 February 1990
\
\  Last updated on: 21 August 1990
\
\  Dependencies:
\       (forth) forth, compiler, structures, blocks, internals
\
\  Description:
\       Top down parser virtual machine instructions.
\
\  Copying:
\       This program is free software; you can redistribute it and\or modify
\       it under the terms of the GNU General Public License as published by
\       the Free Software Foundation; either version 1, or (at your option)
\       any later version.
\
\       This program is distributed in the hope that it will be useful,
\       but WITHOUT ANY WARRANTY; without even the implied warranty of
\       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\       GNU General Public License for more details.
\
\       You should have received a copy of the GNU General Public License
\       along with this program; see the file COPYING.  If not, write to
\       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

.( Loading Parser definitions...) cr

#include internals.f83
#include structures.f83
#include blocks.f83

vocabulary parser ( -- )

compiler blocks structures parser definitions

\ Grammer symbol structure

struct.type symbol ( -- )
  ptr +entry ( symbol -- addr) private
  ptr +syntax ( symbol -- addr) private
  ptr +primary ( symbol -- addr) private
struct.init ( symbol -- )
  last over +entry !            ( Assign pointer back to entry)
  nil over +syntax !            ( Initiate syntax pointer)
  nil swap +primary !            ( Initiate primary pointer)
struct.end

\ Grammer production structure

struct.type rule ( -- ) private
  ptr +next ( rule -- addr) private
  ptr +rule ( rule -- addr) private
struct.end

\ Scanner buffer and break function pointer

variable buffer ( -- addr)
variable >buffer ( -- addr)
variable >break ( -- addr)
variable >skip ( -- addr)

: skip-white-space ( addr1 -- addr2)
  begin                    ( Skip blanks before symbol)
    dup c@ dup                ( Fetch the character)
    32 > not swap            ( Check if it is not a character)
    0= not and                ( Check if it is not null)
  while
    1+                    ( Step to next character)
  repeat
;

' skip-white-space >skip !        ( Assign initiate skip function)

: break-on-special ( addr1 -- bool)
  c@                    ( Fetch next character)
  dup ascii a ascii z ?within        ( Check if a lowercase letter)
  if drop false                ( Return false)
  else
    dup ascii A ascii Z ?within        ( Check if a uppercase letter)
    if drop false            ( Return false)
    else
      ascii 0 ascii 9 ?within not    ( Check if not a digit character)
    then
  then
;

: break-on-white-space ( addr -- bool)
  c@ 32 > not                 ( Forth word break function)
;

' break-on-special >break !        ( Assign initiate break function)

: scan ( -- addr n)
  >buffer @                ( Start scanning in input buffer)
  >skip @ execute            ( Perform skip function)
  dup                    ( Save pointer to beginning)
  dup >break @ execute            ( Use break function)
  if dup c@                ( Check for a single break character)
    if 1+ then                ( Increment to capture)
  else
    begin
      1+                ( Increment to next character)
      dup >break @ execute        ( Use break function)
    until                ( Time to stop scanning)
  then
  dup >buffer !                ( Save pointer to next character)
  over -                ( Calculate number of characters)
;

\ String matching function

#ifundef -match

: -match ( addr1 addr2 n -- bool)
  ?dup                    ( Check for non zero length)
  if >r                    ( Save length)
    begin
      over c@ over c@ =            ( Compare two character)
    while
      1+ swap 1+ swap            ( Move to the next characters)
      r> 1- ?dup            ( Decrement length and check)
      if >r                ( Save length)
      else
    drop drop false exit        ( Drop pointers and return equal)
      then
    repeat
    r> drop                ( Drop length)
  then
  drop drop                ( Drop pointers)
  true                    ( And return not equal)
; private

#then


\ The result of a parse: list of semantic actions

128 constant semantics-size ( -- num) private
create semantics ( -- addr) private semantics-size cells allot
variable >semantics ( -- addr) private

: semantic, ( addr -- )
  >semantics @ !            ( Append to list of semantics)
  cell >semantics +!            ( Point to next free place in list)
;

: bind ( addr -- )
  ['] (literal) semantic,        ( Generate a literal for the parameter)
  semantic,                ( Passed at semantic execution time)
;

\ Parser environment for seize, release and backtrack

: seize ( rule -- rule x y rule)
  dup >r                ( Copy rule parameter)
  >buffer @ >semantics @        ( Build backtrack environment)
  r>                    ( Return copy of rule)
; private

: release ( rule x y -- )
  drop drop drop            ( Drop environment frame)
; private

: backtrack ( x y  -- )
  >semantics ! >buffer !        ( Restore environment frame)
; private

\ Utility function for Parser Virtual Machine Instructions

: rule ( rule -- bool)
  +rule call                ( Execute rule function)
; private

: syntax ( symbol -- bool)
  +syntax @ ?dup            ( Fetch syntax definition)
  if                    ( If available then for all rules)
    begin
      ?dup                ( For all rules)
    while
      seize rule            ( Seize the environment. Check rule)
      if release true exit then        ( If accepted then return accept)
      backtrack                ( Else backtrack to latest environment)
      +next @                ( And try next rule)
    repeat
  then
  false                    ( Return reject)
; private

: primary ( symbol -- bool)
  +primary @ ?dup            ( Fetch primary definition )
  if call                ( If available call function)
  else
    false                ( Else return reject)
  then
; private

\ Parser Virtual Machine Instructions

: terminal ( symbol -- [] or [false])
  +entry @ +name @            ( Access name string for symbol)
  scan -match                ( Scan next token and match)
  if r> drop false then            ( If not equal then reject)
;

: non-terminal ( symbol -- [] or [false])
  dup syntax                ( Try syntax definition)
  if drop true                ( If accepted continue)
  else
    primary                ( If rejected try primary function)
  then
  not
  if r> drop false then            ( If not accepted then reject)
;

: zero-or-one ( symbol -- )
  dup syntax                ( Try syntax definition)
  if drop                ( Drop symbol parameter)
  else
    primary drop            ( Try primary definition)
  then                    ( Always continue)
;

: zero-or-more ( symbol -- )
  begin
    dup syntax                ( Try syntax definition)
    if true                ( One more time)
    else
      dup primary            ( Try primary definition)
    then
    not                    ( Check for more)
  until
  drop                    ( Drop symbol parameter and continue)
;

: semantic ( -- true)
  r> @ semantic, true            ( Append semantic function and accept)
;

: no-semantic ( -- true)
  r> drop true                ( Always return accepted)
;

\ Low Level Parser Interaction

forth

: parse ( symbol -- [semantics] or [false])
  buffer @ >buffer !            ( Initiate buffer pointer)
  semantics >semantics !        ( And list of semantics)
  syntax                ( Try syntax definition)
  if ['] exit semantic,            ( If accepted the append exit)
    semantics                ( And return the list of semantics)
  else
    false                ( Return not parsed)
  then
;

: parse" ( symbol -- )
  ascii " word buffer !            ( Parse the following string)
  parse ?dup                ( Use the parameter symbol syntax)
  if call                ( Call the semantic actions if parsed)
  else
    ." No parse" cr            ( Else no parse message)
  then
; execution

\ High Level Interaction Top Loop

256 constant interact-buffer-size ( -- num) private
create interact-buffer ( -- addr) private interact-buffer-size allot

: interact ( symbol -- )
  interact-buffer buffer !        ( Assign input buffer)
  begin
    interact-buffer            ( Input buffer for interact)
    interact-buffer-size expect        ( Read a line to input buffer)
    span @                ( Check for empty lines)
    if 0 interact-buffer span @ + c!    ( Null terminal the line)
      dup parse ?dup            ( Try parsing it)
      if call                ( If parsed the call semantic actions)
      else
    buffer @ >buffer !        ( Rescan for forth to level loop)
    ['] forth +name @        ( Use forth name field)
    scan -match            ( Scan first token and match)
    if ." No parse" cr        ( Else no parse possible)
    else
      drop exit            ( Drop parameter symbol and exit)
    then
      then
    then
  again
;

\ Syntax for definition of primary functions and syntax rules

: primary ( symbol -- )
  here swap +primary !            ( Add primary function to symbol)
  ]                    ( Start compiling primary function)
;

: end.primary ( -- )
  [compile] ;                ( Stop compiling primary function)
; immediate compilation

: syntax ( symbol -- )
  dup +syntax @ ?dup            ( Check if the symbol has syntax)
  if swap drop                ( Append last in list of rules)
    begin
      dup +next @ ?dup            ( Check if this is the last rule)
    while                ( If not then step to next rule)
      swap drop
    repeat
    here swap +next !            ( Link into list of rules)
  else
    here swap +syntax !            ( Add as first rule)
  then
  nil , ]                ( And start compiling the rule)
;

: end.syntax ( -- )
  [compile] [                ( Stop compiling the rule)
; immediate compilation

\ Basic primary functions: empty, eoln, number och entry

parser

symbol empty ( -- symbol)
symbol eoln ( -- symbol)
symbol number ( -- symbol)
symbol identifier ( -- symbol)
symbol entry ( -- symbol)

empty primary ( -- true)
  true                    ( Always accept)
end.primary

eoln primary ( -- bool)
  scan swap drop 0=            ( Scan next token and check length)
end.primary

number primary ( -- bool)
  scan                    ( Scan next token and check length)
  if dup 0 swap                ( Convert to a number and check)
    convert rot =
    if drop false            ( If not a number reject)
    else
      bind true                ( Else bind the number and accept)
    then
  else
    drop false                ( If no token scanned the reject)
  then
end.primary

identifier primary ( -- bool)
  scan ?dup                ( Scan next token and check length)
  if over c@ dup            ( Fetch first character and check)
     ascii a ascii z ?within swap    ( A lowercase letter or)
     ascii A ascii Z ?within or        ( A uppercase letter )
     if swap bind bind true        ( Bind identifier string and accept)
     else
       drop drop false            ( Reject this parse)
     then
   else
     drop false                ( Reject this parse. No more input)
   then
end.primary

parser

\ Token buffer for vocabulary lookup

128 constant token-size ( -- num) private
create token ( -- addr) token-size allot private

entry primary ( -- bool)
  scan ?dup                ( Scan next token and check length)
  if dup >r                ( Save length of scan string)
    token swap cmove            ( Assign token string and)
    0 token r> + c!            ( terminate with a null character)
    token find                ( Try to locate the symbol)
    if dup +code @ VOCABULARY =        ( Check if the entry is a vocabulary)
      if scan 1 =            ( Scan next token and check length)
    if c@ ascii : =            ( Check first character as colon)
      if >break @            ( Fetch old break function)
        ['] break-on-white-space    ( Use forth word break function)
        >break !            ( as the scanner break function)
        scan             ( Scan again for token)
        rot >break !        ( Restore old break function)
        ?dup            ( Check length)
        if dup >r            ( Pack as a null terminated string)
          token swap cmove        ( Move string)
          0 token r> + c!        ( Pad with null character)
          token swap lookup        ( Look for the token in the vocabulary)
          if bind true exit then    ( If found then bind, accept and exit)
        then
        drop            ( Drop string parameter)
      then
    then
      else
    bind true exit            ( Bind symbol and accept)
      then
    then
  then
  drop false                ( If no token scanned the reject)
end.primary

forth only