Recognizer included

Makefile.in

@@ -181,6 +181,7 @@ KERN_SRC = \
 	kernel/basics.fs \
 	kernel/int.fs \
 	kernel/comp.fs \
+	kernel/recognizer.fs \
 	kernel/io.fs \
 	kernel/input.fs \
 	kernel/license.fs \

cross.fs

@@ -765,6 +765,7 @@ Plugin ?do,	( -- ?do-token )
 Plugin for,	( -- for-token )
 Plugin loop,	( do-token / ?do-token -- )
 Plugin +loop,	( do-token / ?do-token -- )
+Plugin -loop,	( do-token / ?do-token -- )
 Plugin next,	( for-token )
 Plugin leave,	( -- )
 Plugin ?leave, 	( -- )
@@ -1726,7 +1727,7 @@ T has? relocate H
 
 Ghost (do)      Ghost (?do)                     2drop
 Ghost (for)                                     drop
-Ghost (loop)    Ghost (+loop)                   2drop
+Ghost (loop)    Ghost (+loop)   Ghost (-loop)   2drop drop
 Ghost (next)                                    drop
 Ghost !does                                     drop
 Ghost compile,                                  drop
@@ -3233,6 +3234,10 @@ Cond: ENDCASE   endcase, ;Cond
   1to compile (+loop)  loop] 
   compile unloop skiploop] ;			' (+loop,) plugin-of +loop,
 
+: (-loop,) ( target-addr -- )
+  1to compile (-loop)  loop] 
+  compile unloop skiploop] ;			' (-loop,) plugin-of -loop,
+
 : (next,) 
   compile (next)  loop] compile unloop ;	' (next,) plugin-of next,
 
@@ -3242,6 +3247,7 @@ Cond: FOR	for, ;Cond
 
 Cond: LOOP	1 ncontrols? loop, ;Cond
 Cond: +LOOP	1 ncontrols? +loop, ;Cond
+Cond: -LOOP	1 ncontrols? -loop, ;Cond
 Cond: NEXT	1 ncontrols? next, ;Cond
 
 \ String words                                         23feb93py

float.fs

@@ -141,6 +141,22 @@ DOES> ( -- r )
 	2drop false
     THEN ;
 
+[ifdef] recognizer:
+    ' noop
+    :noname postpone Fliteral ;
+    dup
+    recognizer: r:fnumber
+
+    :noname ( addr u -- nt int-table true | addr u false )
+    2dup sfnumber  dup
+    IF
+	drop 2drop r:fnumber  true
+    THEN ; Constant fnum-recognizer
+
+fnum-recognizer
+forth-recognizer get-recognizers
+1+ forth-recognizer set-recognizers
+[else]
 [ifundef] compiler-notfound1
 defer compiler-notfound1
 ' no.extensions IS compiler-notfound1
@@ -170,6 +186,7 @@ IS compiler-notfound1
 	defers interpreter-notfound1
     ENDIF ;
 IS interpreter-notfound1
+[then]
 
 : fvariable ( "name" -- ) \ float f-variable
     Create 0.0E0 f, ;

kernel/comp.fs

@@ -364,9 +364,13 @@ has? primcentric [IF]
 	swap POSTPONE aliteral compile,
     then ;
 
+has? recognizer [IF]
+    include ./recognizer.fs
+[ELSE]
 : POSTPONE ( "name" -- ) \ core
     \g Compiles the compilation semantics of @i{name}.
     COMP' postpone, ; immediate
+[THEN]
 
 \ \ recurse							17may93jaw
 
@@ -376,6 +380,7 @@ has? primcentric [IF]
 
 \ \ compiler loop
 
+has? recognizer 0= [IF]
 : compiler1 ( c-addr u -- ... xt )
     2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
     if ( c-addr u nt )
@@ -403,6 +408,7 @@ has? primcentric [IF]
 : ] ( -- ) \ core	right-bracket
     \G Enter compilation state.
     ['] compiler1     IS parser1 state on  ;
+[THEN]
 
 \ \ Strings							22feb93py
 

kernel/int.fs

@@ -693,6 +693,7 @@ has? backtrace [IF]
     then ;
 [THEN]
 
+has? recognizer 0= [IF]
 \ not the most efficient implementations of interpreter and compiler
 : interpreter1 ( c-addr u -- ... xt ) 
     2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
@@ -709,6 +710,7 @@ has? backtrace [IF]
     then ;
 
 ' interpreter1  IS  parser1
+[THEN]
 
 \ \ Query Evaluate                                 	07apr93py
 

kernel/kernel.fs

@@ -22,7 +22,7 @@
 has? interpreter [IF]
     include ./int.fs
     has? compiler [IF]
-        include ./comp.fs
+	include ./comp.fs
     [THEN]
 [THEN]
 has? new-input [IF]

kernel/recognizer.fs

@@ -15,18 +15,16 @@
 \ interpret it, compile interpretation semantics
 \ compile it, compile it as literal.
 
-: recognizer: ( xt1 xt2 xt3 xt4 -- ) Create 2swap swap 2, swap 2, ;
+: recognizer: ( xt1 xt2 xt3 -- ) Create rot , swap , , ;
 
-(field) r>int     ( r-addr -- addr )  0 cells ,
-(field) r>compint ( r-addr -- )       1 cells ,
-(field) r>comp    ( r-addr -- )       2 cells ,
-(field) r>lit     ( r-addr -- )       3 cells ,
+(field) r>int      ( r-addr -- addr )  0 cells ,
+(field) r>comp     ( r-addr -- )       1 cells ,
+(field) r>lit      ( r-addr -- )       2 cells ,
 
 :noname ( ... nt -- ) name>int execute ;
-:noname ( ... nt -- ) name>int compile, ;
 :noname ( ... nt -- ) name>comp execute ;
 :noname ( ... nt -- ) postpone Literal ;
-recognizer: r:interpreter
+Create r:interpreter rot A, swap A, A,
 
 :noname ( addr u -- nt int-table true | addr u false )
     2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
@@ -37,14 +35,14 @@ recognizer: r:interpreter
 ' noop
 :noname  postpone Literal ;
 dup
-dup
-recognizer: r:number
+Create r:number rot A, swap A, A,
 
 ' noop
 :noname  postpone 2Literal ;
 dup
-dup
-recognizer: r:2number
+Create r:2number rot A, swap A, A,
+
+\ snumber? should be implemented as recognizer stack
 
 :noname ( addr u -- nt int-table true | addr u false )
     2dup 2>r snumber?  dup
@@ -53,12 +51,11 @@ recognizer: r:2number
     THEN
     drop 2r> false ; Constant num-recognizer
 
-' no.extensions dup 2dup recognizer: r:fail
+' no.extensions dup dup Create r:fail A, A, A,
 
 \ recognizer stack
 
 $10 Constant max-rec#
-Variable forth-recognizer max-rec# cells allot
 
 : get-recognizers ( rec-addr -- xt1 .. xtn n )
     dup cell+ swap @ dup >r cells bounds ?DO
@@ -71,7 +68,11 @@ Variable forth-recognizer max-rec# cells allot
 	I !
     cell -LOOP ;
 
-num-recognizer int-recognizer 2 forth-recognizer set-recognizers
+Variable forth-recognizer
+
+int-recognizer A, num-recognizer A, max-rec# 2 - cells allot
+2 forth-recognizer !
+\ num-recognizer int-recognizer 2 forth-recognizer set-recognizers
 
 \ recognizer loop
 
@@ -92,6 +93,8 @@ num-recognizer int-recognizer 2 forth-recognizer set-recognizers
 : interpreter-r ( addr u -- ... xt )
     forth-recognizer do-recognizer r>int @ ;
 
+' interpreter-r IS parser1
+
 : compiler-r ( addr u -- ... xt )
     forth-recognizer do-recognizer r>comp @ ;
 
@@ -103,8 +106,11 @@ num-recognizer int-recognizer 2 forth-recognizer set-recognizers
     \G Enter compilation state.
     ['] compiler-r     IS parser1 state on  ;
 
+: >postpone ( token table -- )
+    dup r:fail = IF  no.extensions  THEN
+    >r r@ r>lit perform r> r>comp @ compile, ;
+
 : postpone ( "name" -- ) \ core
     \g Compiles the compilation semantics of @i{name}.
-    parse-name forth-recognizer do-recognizer >r
-    r@ r>lit perform r> r>comp @ compile, ; immediate
+    parse-name forth-recognizer do-recognizer >postpone ; immediate
 

machpc.fs.in

@@ -58,6 +58,8 @@ false DefaultValue control-rack \ disable return stack use for control flow
 
 false DefaultValue crlf
 
+true DefaultValue recognizer
+    
 $100 DefaultValue kernel-start
 cell 2 = [IF] &32 KB [ELSE] $100000 cells [THEN] DefaultValue kernel-size
 
@@ -109,6 +111,8 @@ true DefaultValue control-rack  \ disable return stack use for control flow
 
 false DefaultValue crlf
 
+false DefaultValue recognizer
+    
 false DefaultValue flash
     
 $10 DefaultValue kernel-start   \ no artificial offset

stuff.fs

@@ -181,6 +181,18 @@ AUser CSP
 : ]] ( -- ) \ gforth right-bracket-bracket
     \G switch into postpone state
     ['] postponer1 is parser1 state on ; immediate restrict
+[then]
+
+[ifdef] compiler-r
+: postponer-r ( addr u -- ... xt )
+    forth-recognizer do-recognizer
+    over [ s" [[" find-name ] Literal =
+    IF  2drop [comp'] ] drop ELSE  ['] >postpone  THEN ;
+
+: ]] ( -- ) \ gforth right-bracket-bracket
+    \G switch into postpone state
+    ['] postponer-r is parser1 state on ; immediate restrict
+[then]
 
 comp'  literal drop alias postpone-literal
 comp' 2literal drop alias postpone-2literal
@@ -204,8 +216,6 @@ comp' sliteral drop alias postpone-sliteral
 \G allocated permanently, you can use @code{]]2L} instead.
     ]] postpone-sliteral ]] [[ ; immediate
 
-[then]
-
 \ f.rdp
 
 : push-right ( c-addr u1 u2 cfill -- )