Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.
Dismiss

Moore's tinybasic revisited.

103 views
Skip to first unread message

Albert van der Horst

unread,
Oct 21, 2016, 8:43:10 PM10/21/16
to
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

0 new messages