Revisiting the tiny basic in Forth.
Refer to the tinybasic in
http://www.nicholson.com/rhn/files/Tiny_BASIC_in_Forth.txt
See also the related thread.
This is the way the BASIC operators are defined:
5 PRECEDENCE **
4 PRECEDENCE * 4 PRECEDENCE / 4 PRECEDENCE */
3 PRECEDENCE + 3 PRECEDENCE -
This is the word that does it:
: PRECEDENCE ( n) >IN @ ' >R >IN ! CONSTANT R> ,
IMMEDIATE DOES> 2@ DEFER ;
So e.g. in `` 4 PRECEDENCE * ' the name * is scanned twice,
once by ' and once by CONSTANT. This requires that the
operator in BASIC has the exact same name than in Forth.
Also PRECEDENCE is a bad name, We're defining an infix operator
here, whose priority is 4. So we arrive at:
' * 4 INFIX * etc.
with
: INFIX ( xt prio -- ) CREATE IMMEDIATE 2, DOES 2@ DEFER ;
While we're at it we can replace
: ** ( n n - n) 1 SWAP 1 DO OVER * LOOP * ; 5 PRECEDENCE **
(requiring corresponding names)
by
:NONAME ** ( n n - n) 1 SWAP 1 DO OVER * LOOP * ; 5 INFIX **
Now we'll discuss an actual defect.
We see
6 PRECEDENCE ABS
Let's add another of the kind prefix, the unary minus so
' ABS 6 INFIX ABS ' NEGATE 6 INFIX NEGATE
: RUN BASIC
10 PRINT ABS NEGATE 10
20 PRINT NEGATE ABS 10
30 END
Disaster strikes. A huge number is printed.
To find out the reason, let's recapitulate how DEFER works.
: DEFER ( a n a n - a n) #( @ +
BEGIN 2OVER NIP OVER >= WHILE 2SWAP DROP , REPEAT ;
( The , is the compilation of the operator into the basic program)
Take the example
2 + 4 * 5 -
Output 2
+ : priority 3, there is only lower priority on the stack, so
during while no operator is found to output.
output 4
* : priority 4 , still no lower priority
output 5
- priority 3, the * has higher priority so it can be output.
the + has equal priority so it can too.
So the Forth equivalent is compiled (and the - is remembered)
2 4 5 * +
Now look at
2 + abs 4 -
Output 2
+ priority 3, there is only lower priority on the stack, so during
while no operator is found to output.
abs priority 6 , no higher priority found.
*but it would be a disaster if we did, because the operand for
the + is still not there*.
So the high priority of abs is a cludge to avert this disaster.
The defect is show by
10 PRINT 2 + negate abs 13
Now ABS does find an operator with the same priority to execute,
NEGATE . This operates on the wrong number (2) and then the +
operates on too few parameters, even worse.
A prefix operator has no business calling DEFER, it must wait
patentiently until its operand arrives.
Bottom line, we need
: INFIX ( xt prio -- ) CREATE IMMEDIATE 2, DOES 2@ DEFER ;
: PREFIX ( xt prio -- ) CREATE IMMEDIATE 2, DOES 2@ ;
The reasoning for postfix is as follows. Let's say we have !
faculty, which has a higher priority then + and lower than **.
10 print 2 + 2 ** 2 !
should print 26 ( 4! = 24 )
! finds
operand stack 2 2 2
operator stack + 3 ** 5 !-xt 4
** has larger priority so it is exported, and at + it stops.
but now **'s single operand is available so
A postfix operator must always be exported immiediately after
its DEFER action, because its operand is present, and nothing
can affect the outcome of executing it.
: POSTFIX ( xt prio -- ) CREATE IMMEDIATE 2, DOES 2@ DEFER
DROP , ;
This is pretty pretty, but it becomes prettier still.
If we make ( a prefix operator and ) a postfix operator
with appropriate priorities the parenthesis can be handled with
this mechanism too. They must have a priority below all arithmetic
and logic. So we can do away with the variable #) that adds to
the priorities inside brackets.
Appendix
: run basic
10 print 2 + NEGATE ABS 10
20 END
RUN
gives 8 instead of the expected -8 (before the fix).
This is the code deblockified, with anachronism removed, with
auxiliary words inlined, the above improvements,
extra operators NEGATE and !!, and shamelessly using ciforthisms.
Note: {{{ }}} is a lightweight :NONAME ; .
Not counting the extra !! operator, it is still 8 screens.
----------------------------------
\ BASIC compiler screen zero for all
\ Target Forth : ciforth 5.3
\ Authors : Moore (original) , Perry , vd Horst
WANT >= VOCABULARY TRUE [:
: ON 1 SWAP ! ;
: OFF 0 SWAP ! ;
\ The EXECUTE-PARSING of 5.3 fails, so do it explicitly.
: NUMBER SAVE SET-SRC '(NUMBER) CATCH RESTORE THROW ;
\ BASIC compiler
ONLY FORTH ALSO DEFINITIONS
VOCABULARY ARITHMETIC ARITHMETIC ALSO DEFINITIONS
VOCABULARY LOGIC VOCABULARY INPUTS VOCABULARY OUTPUTS
: GET NAME NUMBER DROP ;
CREATE #S 10000 ALLOT
FORTH DEFINITIONS
\ Precedence
VARIABLE ADDRESS
: DEFER ( a n a n - a n)
BEGIN 2OVER NIP OVER >= WHILE 2SWAP DROP , REPEAT ;
: INFIX ( op pr) CREATE , , IMMEDIATE DOES> 2@ DEFER ;
: PREFIX ( op pr) CREATE , , IMMEDIATE DOES> 2@ ;
: POSTFIX ( op pr) CREATE , , IMMEDIATE DOES> 2@ DEFER
SWAP , 1- OVER = IF DROP , THEN ;
: RPN ( n) 0 1 DEFER 2DROP ABORT" Syntax" ;
: START ( - n) ADDRESS OFF 'NOOP 0 ARITHMETIC ;
\ Variables
: INTEGER CREATE 1 CELLS ALLOT IMMEDIATE DOES> POSTPONE LITERAL
ADDRESS @ IF ADDRESS OFF ELSE POSTPONE @ THEN ;
: (ARRAY) ( a a) SWAP >R 18 DEFER R> POSTPONE LITERAL
ADDRESS @ IF ADDRESS OFF ELSE '@ 18 2SWAP THEN ;
: [+] ( a i - a) 1- CELLS + ;
: ARRAY INTEGER 1- CELLS ALLOT DOES> '[+] (ARRAY) ;
: [*+] ( a x y - a) >R 1- OVER @ * R> + CELLS + ;
: 2ARRAY ( y x) CREATE IMMEDIATE DUP , * CELLS ALLOT
DOES> '[*+] (ARRAY) ;
: BASIC [ ARITHMETIC ] 0 #S CELL+ #S 2! START ALSO ; IMMEDIATE
ARITHMETIC DEFINITIONS
\ Statement numbers ( works at any address )
: FIND ( line# -- entry-adr ) TRUE #S @ #S CELL+
?DO OVER I @ ABS = IF 2DROP I FALSE LEAVE THEN 2 CELLS +LOOP
IF 0 SWAP #S @ 2! #S @ 2 CELLS #S +! THEN ;
: RESOLVE ( n -- ) FIND DUP @ 0< ABORT" duplicated"
DUP @ NEGATE OVER ! CELL+ DUP @
BEGIN ?DUP WHILE DUP @ HERE ROT ! REPEAT HERE SWAP ! ;
: CHAIN ( n - a) FIND $@ 0<
IF @ ELSE DUP @ HERE ROT ! THEN ;
: STATEMENT ( n -- ) HERE 1 CELLS - @ >R -2 CELLS ALLOT RPN EXECUTE
R> RESOLVE START ;
\ Branching - high level
: JUMP R> @ >R ;
: CALL R> DUP @ SWAP CELL+ >R >R ;
: SKIP 0= IF R> 2 CELLS + >R THEN ;
: (NEXT)
2DUP +! >R 2DUP R> @ SWAP
0< IF SWAP THEN -
0< IF 2DROP R> CELL+ ELSE R> @ THEN >R ;
: [1] POSTPONE 1 HERE ;
: [NEXT] POSTPONE (NEXT) , ;
: (GOTO) GET POSTPONE JUMP CHAIN , ;
: (RET) R> DROP ;
\ BASIC
: LET STATEMENT ADDRESS ON ; IMMEDIATE
: FOR POSTPONE LET ; IMMEDIATE
: TO RPN DROP '[1] 0 ; IMMEDIATE
: STEP RPN DROP 'HERE 0 ; IMMEDIATE
: NEXT STATEMENT 2DROP '[NEXT] 0 ADDRESS ON ; IMMEDIATE
: REM STATEMENT POSTPONE \ ; IMMEDIATE
: DIM POSTPONE REM ; IMMEDIATE
: STOP STATEMENT POSTPONE (RET) ; IMMEDIATE
: END STATEMENT 2DROP POSTPONE ; PREVIOUS FORTH ; IMMEDIATE
: GOTO STATEMENT (GOTO) ; IMMEDIATE
: IF STATEMENT LOGIC ; IMMEDIATE
: THEN RPN 0 POSTPONE SKIP (GOTO) ; IMMEDIATE
: RETURN STATEMENT POSTPONE (RET) ; IMMEDIATE
: GOSUB STATEMENT GET POSTPONE CALL CHAIN , ; IMMEDIATE
\ Input and Output
: ASK ." ? " (ACCEPT) SET-SRC ;
: PUT GET SWAP ! ;
: (INPUT) POSTPONE PUT ;
: (.R) ( n) 14 .R SPACE ;
OUTPUTS DEFINITIONS
: " POSTPONE ." 2DROP ; IMMEDIATE
'(.R) 1 INFIX ,
'. 1 INFIX ;
INPUTS DEFINITIONS
: , RPN 0 (INPUT) ADDRESS ON ; IMMEDIATE
ARITHMETIC DEFINITIONS
: PRINT STATEMENT POSTPONE CR '(.R) 1 OUTPUTS ; IMMEDIATE
: INPUT STATEMENT 2DROP POSTPONE ASK '(INPUT) 0 INPUTS
ADDRESS ON ; IMMEDIATE
\ Operators
LOGIC DEFINITIONS
'<> 6 INFIX <> '<= 6 INFIX <= '>= 6 INFIX >=
'= 6 INFIX = '< 6 INFIX < '> 6 INFIX >
ARITHMETIC DEFINITIONS
{{{ ( n n - n) 1 SWAP 1 DO OVER * LOOP * }}} 12 INFIX **
{{{ ( n - n) 1 OVER 1 DO I * LOOP * }}} 10 POSTFIX !!
'ABS 10 PREFIX ABS 'NEGATE 8 PREFIX NEGATE
'* 10 INFIX * '/ 10 INFIX / '*/ 10 INFIX */
'+ 8 INFIX + '- 8 INFIX -
{{{ ( a n) SWAP ! }}} 1 INFIX =
'NOOP 3 PREFIX ( 'NOOP 4 POSTFIX )
FORTH DEFINITIONS
------------------------
Groetjes Albert
--
Albert van der Horst, UTRECHT,THE NETHERLANDS
Economic growth -- being exponential -- ultimately falters.
albert@spe&ar&
c.xs4all.nl &=n
http://home.hccnet.nl/a.w.m.van.der.horst