tcl set engine engine3b.c

  Hprims COL RSR CON TO AT C1 C2 C3
 SFprims EXIT PLUS DUP 2DUP 1 SWAP DROP STORE FETCH
  Fprims COUNT TYPE CR STO TOS SGOBBLE1 SGOBBLE2 SGOBBLE4 WSTORE WFETCH
  Fprims SBRANCH S0BRANCH  FRAME1N FRAMENTOADR FRAME2ADR 2BECOMES1
  Fprims PRINTFRAMES
 SFprims C SRANGE
FIPprims RETURN RSREXIT

syns  COL: :  STORE !  FETCH @
syns  EXIT ;  PLUS +  STO S>  TOS >S  WSTORE W!  WFETCH W@

syns  FRAME1N 1.FRAME#  FRAME2ADR 2.ADR  FRAMENTOADR FRAME#->ADR
syns  SGOBBLE2 SGOBBLEADR

tcl arrset action "tclword:" { arrset action [getword] [getrest] }
tclword: ## getrest
tclword: ### getrest
tclword: ##### getrest



#####
#
# Tools: strlen, 0<.">, S0<.">, tclword:, 0.",
#        BRANCH, 0BRANCH, YES/NO, SLITW, LITW, lit, litd
#        DBG!, DBG-ON, DBG-OFF
#
#####

' strlen C1: asm extern strlen
	     asm  dd strlen
nasmnames  0<."> 0angdotquo  S0<."> S0angdotquo
'  0<."> RSR:
' S0<.">    : S> DUP strlen 2DUP TYPE + 1 + >S ;
tcl proc p0str {dstr} { asm_now "\td2a ADR_0angdotquo";asm_now "\tdb $dstr,0" }
tclword: 0."  p0str [getrest]
tclword: w"   p0str [getword]

''  BRANCH RSR: :  SBRANCH ;
'' 0BRANCH RSR: : S0BRANCH ;
' YES/NO : 0BRANCH ->no  0." 'yes', 10
	    BRANCH ->end
	           ->no: 0." 'no', 10
		   ->end: ;

syns  SGOBBLE2 SLITW  SGOBBLE4 SLITD
''    LITW RSR: :    SLITW ;
''    LITD RSR: :    SLITD ;
tclword: lit  asm_now "\td2a ADR_LITW"; asm_now "\tdw [getword]"
tclword: litd asm_now "\td2a ADR_LITD"; asm_now "\tdd [getword]"

asm extern DBG_BITS
'  DBG!    : litd DBG_BITS ! ;
'' DBG-ON  : lit -1 DBG! ;
'' DBG-OFF : lit  0 DBG! ;


#####
#
# Basic words to handle frames
# Prims used: 1.FRAME# 2.ADR FRAME#->ADR 2BECOMES1 @ ! W@ W! lit
#
#####

' .IP   :           @ ;     ' .IP!   :           ! ;
' .POS  : lit  4 +  @ ;     ' .POS!  : lit  4 +  ! ;
' .RET  : lit  8 + W@ ;     ' .RET!  : lit  8 + W! ;
' .FAIL : lit 10 + W@ ;     ' .FAIL! : lit 10 + W! ;

' 2.IP!   : 2.ADR .IP!   ;
' 2.POS!  : 2.ADR .POS!  ;
' 2.RET!  : 2.ADR .RET!  ;
' 2.FAIL! : 2.ADR .FAIL! ;
# ( ip pos ret fail -- )
' CREATEFRAME :  2.FAIL! 2.RET! 2.POS! 2.IP!  2BECOMES1 ;

' 1.ADR  : 1.FRAME# FRAME#->ADR ;
' 1.IP   : 1.ADR .IP   ;
' 1.POS  : 1.ADR .POS  ;
' 1.RET  : 1.ADR .RET  ;
' 1.FAIL : 1.ADR .FAIL ;

' RET.ADR  : 1.RET  FRAME#->ADR ;
' RET.IP   : RET.ADR .IP   ;
' RET.POS  : RET.ADR .POS  ;
' RET.RET  : RET.ADR .RET  ;
' RET.FAIL : RET.ADR .FAIL ;

' FAIL.ADR  : 1.FAIL FRAME#->ADR ;
' FAIL.IP   : FAIL.ADR .IP   ;
' FAIL.POS  : FAIL.ADR .POS  ;
' FAIL.RET  : FAIL.ADR .RET  ;
' FAIL.FAIL : FAIL.ADR .FAIL ;



#####
#
# CALL, SALT and friends
#
#####

 '  SDUP>D    :  S> DUP >S ;
 '  FRAME  RSR:
 ' SFRAME     :  SDUP>D 1.POS 1.RET 1.FAIL CREATEFRAME ;

'' SALTPUSH RSR: :  SFRAME
                    SDUP>D 1.POS 1.RET 1.FRAME# CREATEFRAME
                    S> lit 3 + >S SFRAME ;
'' SALTPOP  RSR: :  SBRANCH SDUP>D FAIL.POS FAIL.RET FAIL.FAIL CREATEFRAME ;

# '' CALLPUSH RSR: :  SDUP>D 1.POS 1.FRAME# 1.FAIL CREATEFRAME
#                     SGOBBLE1 DROP SBRANCH ;
# '' CALLPOP  RSR: :  SGOBBLE2 DROP SDUP>D 1.POS RET.RET 1.FAIL CREATEFRAME ;

# CALLPOP is wrong, must start with some sort of SGOBBLEADR

tcl proc addtorest {str} { global rest; set rest "$str $rest" }
tclword: SALT  addtorest "SALTPUSH SALTPOP"

# tclword: CALL  addtorest "CALLPUSH CALLPOP"



#####
#
# RET and FAIL
#
#####

# I'm implementing RET and FAIL with a simple scheme that sets WASRET
# and delegates all the hard work to CALLPOP/SALTPOP/xxxPOP. WASRET's
# function is to tell xxxPOP if what's happening is a RET or a FAIL,
# and will be needed for BCALL; it isn't being used now.

' WASRET! TO:
' WASRET CON:  asm dd 0
' RET  RSR: ' SRET  :  S> DROP  lit 1 WASRET!  RET.IP  >S ;
' FAIL RSR: ' SFAIL :  S> DROP  lit 0 WASRET!  FAIL.IP >S ;


#####
#
# words for character ranges
#
#####

'' RANGE RSR: : SRANGE ;
'' CIN RSR:
' SCIN :  DROP 0BRANCH ->cinfail
            S> DUP >S 1.POS 1 + 1.RET 1.FAIL CREATEFRAME ;
           ->cinfail: SFAIL ;
tcl proc cmatch {str} { asm_now "\tdb SF_C, $str, SF_CIN" }
tclword: [-]   cmatch "SF_RANGE,'--'"
tclword: [0-9] cmatch "SF_RANGE,'09'"
tclword: [.]   cmatch "SF_RANGE,'..'"




# (eeman "perlre" "greedy")

# x?	     SALT ->1  x ->1:
# x*    ->1: SALT ->2  x GOTO ->1  ->2:
# x+	->1:           x GSALT ->1

# x??	     GSALT ->1 x ->1:
# x*?   ->1: GSALT ->2 x GOTO ->1  ->2:
# x+?	->1:           x SALT ->1

# x|y	     SALT ->1  x GOTO ->2 ->1: y ->2:

' PF RSR: : SFRAME PRINTFRAMES ;
tclword: PF: set s [getword]; p0str "'$s',10"; asm_now "\td2a ADR_PF; === $s"

g' BIGFAIL 0." 'failed!',10
  ;
g' DEMO :
  ->1:     PF: a   [0-9]
           PF: b   SALT ->1
           PF: c   [0-9] 
           PF: d   [.]
           PF: e
  ;

# g' DEMO :  PF: a  SALT ->1
#            PF: b  SALT ->2
#            PF: c  FAIL
#            PF: d  ->2:
#            PF: e  FAIL
#            PF: f  ->1:
#            PF: g  ;