ctran5.f




FALSE [IF]

******** ANS-compatible Expression -> CODE parser ********

---------------------------------------------------
    (C) Copyright 2000  Julian V. Noble.
      Permission is granted by the author to      
      use this software for any application pro-  
      vided this copyright notice is preserved,
      as per GNU Public License agreement.
---------------------------------------------------


---------------------------------------------------
Environmental dependencies:
      ANS CORE, CORE EXT and LOCALS EXT wordsets

      Assumes the referencing used in Win32Forth
      and the assembler mnemonics of 486asm.f
---------------------------------------------------


Compiler documentation:
----------------------------- Backus-Naur Rules
NOTATION:
|               -> "or",
+               -> "unlimited repetitions"
&               -> + | -
%               -> * | /

Does not recognize numeric literals.

FORMULAS:
assignment    -> id = expression
expression    -> term |  expression & term
term          -> factor | term % factor
factor        -> id | ( expression )
id            -> letter {letter|digit}+
-------------------------- end Backus-Naur Rules


Usage:      cf" a = b + c*d"  within a CODE definition
compiles    fld  FSIZE b [edi]
            fld  FSIZE c [edi]
            fmul  FSIZE d [edi]
            faddp  st(1), st  fstp
            FSIZE a [edi]

For testing, cf." is supplied--outputs above to console.

*** BE CAREFUL NOT TO USE VARIABLE NAMES LIKE dx ***

[THEN]


MARKER -codetran

BL PARSE [undefined] DUP PAD C! PAD CHAR+ SWAP CHARS MOVE PAD FIND NIP 0=
[IF]  : [undefined]   BL WORD  FIND  NIP  0=  ;  [THEN]

[undefined]  -ROT  [IF]
    : -ROT    S" ROT ROT"  EVALUATE  ; IMMEDIATE
[THEN]

[undefined] f"  [IF]  include ftran111.f      [THEN]

CR CR .( *** BE CAREFUL NOT TO USE VARIABLE NAMES LIKE dx *** ) CR
      .( *** that CODE will misconstrue as register names *** )


: a|b     ( c1 c2 )     \ defining word for words that find one of two
                        \ possible characters
    CREATE  , ,         
    DOES>  ( c -- f)   2@  ROT  TUCK  =  -ROT  =  OR  ;

CREATE Ctran  512 CHARS CELL+  ALLOT    \ hold output from cf"  "
: init_Ctran    0 Ctran !  ;   init_Ctran

: (concat)    ( c-adr u --)
    >R  Ctran  CELL+  Ctran @  +  R@   CMOVE
    R>  Ctran @ +  Ctran ! ;

\ Note: output from modest expressions can easily exceed 255 chars,
\       hence a long-string buffer was employed


VARIABLE ()level    0 ()level !  \ holds current parens level

: ()level!    ( c --)   \ increment/decrement ()level
    [CHAR] )  OVER  =   SWAP
    [CHAR] ( =   -   ()level +!  ;

: adr>ends  ( $adr -- beg end)  COUNT  OVER +  1-  ;

: skip-     ( adr -- adr | adr+1)  DUP  C@  [CHAR] - =  -  ;

: find2     ( beg end xt -- adr|0 )
    LOCALS| xt end beg |                    \ search right to left
    0 ()level !  beg  skip-  TO beg         \ initialize
    0  beg end
    DO  I C@   DUP    ()level!              \ adjust ()level
        xt EXECUTE    ( -- f)               \ test input
        ()level @  0=                       \ exposed?
        AND                                 \ found?
        IF   DROP  I  LEAVE   THEN          ( -- adr)
    -1 +LOOP
;



CHAR +  CHAR -  a|b  +|-
CHAR *  CHAR /  a|b  *|/


v: (output)                 ( initialized to NOOP)
v: expression

: print_op   ( .op --)
    CASE
        [CHAR] _  OF   S"  fchs "              ENDOF
        [CHAR] +  OF   S"  faddp  st(1), st "  ENDOF
        [CHAR] -  OF   S"  fsubp  st(1), st "  ENDOF
        [CHAR] *  OF   S"  fmulp  st(1), st "  ENDOF
        [CHAR] /  OF   S"  fdivp  st(1), st "  ENDOF
    ENDCASE
    (concat)  ;

: (print_id)   ( beg end --)   OVER -  1+  (concat)  ;

: (print_op)   ( beg end .op --)
    CASE
        [CHAR] +  OF   S"  fadd  FSIZE "  ENDOF
        [CHAR] -  OF   S"  fsub  FSIZE "  ENDOF
        [CHAR] *  OF   S"  fmul  FSIZE "  ENDOF
        [CHAR] /  OF   S"  fdiv  FSIZE "  ENDOF
    ENDCASE
    (concat)  (print_id)  S"  [edi] "  (concat)  ;


VARIABLE BLBL   2 BLBL C!  BL BLBL CHAR+ C!  BL BLBL CHAR+ CHAR+ C!
: 0null   BLBL   adr>ends  ;



: print_id   ( beg end .op -- )
    0 LOCALS| -? .op end beg |
    beg C@  [CHAR] -  =   TO -?         \ leading -?
    .op  BL =  IF
        S"  fld  FSIZE "   (concat)     \ id preamble
        beg  -?  -  end  (print_id)     \ id
        S"  [edi] "        (concat)     \ id index
        -?  IF  S"  fchs " (concat)     \ handle leading -
        THEN
    ELSE
        beg end  0null D=               \ solo operator?
        IF      .op  print_op           \ operator ->
        ELSE    beg end .op  (print_op) \ op + id  ->
        THEN
    THEN
;
FALSE [IF] [THEN]


: (<expr>)?   ( beg end -- f)   \ is it an expression in parens?
    C@ [CHAR] ) =   SWAP   C@ [CHAR] ( =   AND  ;




: letter?     ( c -- f)     \ is it a letter?
    32 OR  [CHAR] a  [ CHAR z 1+ ] LITERAL  WITHIN ;

: let_or_dig?      ( c -- f)     \ char = letter or digit?
    DUP
    [CHAR] 0  [ CHAR 9 1+ ] LITERAL  WITHIN
    SWAP   letter? OR  ;

: <id>  ( beg end -- f)         \ <id> -> letter {letter|digit}*
    0 LOCALS| L|D? end beg |
    beg skip-  TO beg           \ ignore leading -
    beg  C@  letter?  TO L|D?   \ 1st char a letter?
    BEGIN  beg 1+  TO beg       \ inc ptr
           end beg  >=          \ not done?
    WHILE  beg  C@  let_or_dig? \ char = letter or digit?
           L|D?  AND   TO L|D?
    REPEAT  L|D? ;


: <factor>  ( beg end .op -- )      \ factor -> <id> | (<expr>)
    LOCALS| .op end beg |
    beg skip-  end  (<expr>)?       \ enclosed?
     IF  end 1- TO end              \ remove )
         beg C@  [CHAR] -  =        \ leading - ?
         IF  beg 2 + TO beg         \ skip- and remove (
             0null [CHAR] _         ( 0beg 0end _ )
         ELSE  beg 1+ TO beg        \ remove (
             0null .op
         THEN
         beg end  BL                ( 0beg 0end ? beg end bl)
         expression
         RECURSE                     \ <factor>
         EXIT
     THEN
    beg end  0null  D=              \ null string ?
    .op  BL  =  AND
    IF  EXIT  THEN
    beg end  <id>                   \ <id> ?
    beg end  0null  D=              \ null string ?
    OR
     IF    beg end .op  print_id    \ output it
     ELSE  ." Incorrect expression!"  ABORT
     THEN
;



: <term>  ( beg end .op -- )        \ term -> factor | term % factor
    0 LOCALS| adr .op end beg |
    beg skip-  end  ['] *|/  find2  \ find * or /
    TO adr
    adr  IF                         \ found?
          0null .op
          adr 1+ end  adr C@
          beg adr 1-  BL
          RECURSE    <factor>
     ELSE  beg end .op
     THEN
    <factor>
;


: <expression>   ( beg end .op -- )     \ expr -> term | expr & term
    0 LOCALS| adr .op end beg |
    beg skip-  end  ['] +|- find2       \ find&
    TO adr
    adr IF                      \ found?
        adr 1+  end  adr C@
        beg adr 1-  .op         \ .op should always be bl
        RECURSE
    ELSE  beg end .op  THEN   <term>  ;


' <expression>  defines  expression         \ make forward reference


CHAR = DUP  a|b  =|=                        \ to find =

: <assign>  ( beg end .op -- )
    0 LOCALS| adr .op end beg |
    init_Ctran                          \ initialize output buffer
    beg end  ['] =|= find2              \ find=
    TO adr
    adr IF                              \ found?
        beg adr 1-  adr C@
        adr 1+  end  .op                ( beg adr-1  '='  adr+1 end  bl)
        expression                      \ parse expression
        S"  fstp FSIZE "  (concat)      \ lhs prefix
        -ROT  (print_id)                \ lhs id
        S"  [edi] "       (concat)      \ lhs suffix
        DROP
    ELSE   beg end .op  expression   THEN
    Ctran  CELL+  Ctran @    (output)   \ output the code
;


: cf."      ( formula, delimited by " -- ) \ for testing
    [']  TYPE   defines (output)
    aword"
    adr>ends   BL  CR  <assign>  ;

: cf"       ( formula, delimited by " -- ) \ for use inside definitions
    [']  EVALUATE   defines (output)
    aword"
    adr>ends   BL  CR  <assign>  ;

\ *******************************************************************
\       These macros are used only within CODE definitions

: eval"   POSTPONE  S"  POSTPONE EVALUATE  ; IMMEDIATE

: (f!)    eval" fstp  FSIZE"
          BL  TEXT  COUNT  EVALUATE
          eval" [edi]"  ;

: (f+!)   eval" fadd FSIZE "
          BL TEXT COUNT  2DUP   EVALUATE
          eval" [edi]  fstp  FSIZE "
          EVALUATE
          eval" [edi] "  ;

FVARIABLE  two    2e0   two  F!
FVARIABLE  half   0.5e0 half F!

: (f2*)     eval" fmul  FSIZE  two   [edi] "  ;
: (f2/)     eval" fmul  FSIZE  half  [edi] "  ;

: (1/f)     eval" fld1  fdiv  FSIZE "
            BL TEXT COUNT  EVALUATE
            eval"  [edi] "   ;

\ *******************************************************************





  HTMLized by Forth2HTML