/
basic.blk
1 lines (1 loc) · 18 KB
/
basic.blk
1
\ BASIC compiler 06Feb84mapONLY FORTH ALSO DEFINITIONS : .R RP0 @ RP@ ?DO I @ 2- @ >NAME .ID 2 +LOOP ; VOCABULARY ARITHMETIC ARITHMETIC ALSO DEFINITIONS VOCABULARY LOGIC VOCABULARY INPUTS VOCABULARY OUTPUTS : [ ASCII ] WORD DROP ; IMMEDIATE : GET BL WORD NUMBER DROP ; CREATE #S 130 ALLOT FORTH DEFINITIONS 1 2 +THRU ( precedence and variables ) : BASIC [ ARITHMETIC ] 0 #S 2+ #S 2! START ALSO ; IMMEDIATE ARITHMETIC DEFINITIONS 3 7 +THRU ( BASIC ) : ( 10 #( +! ; IMMEDIATE : ; [ n] . ; 1 PRECEDENCE ; FORTH DEFINITIONS \ Precedence 06Feb84mapVARIABLE ADDRESS VARIABLE #( : ) -10 #( +! #( @ 0< ABORT" Unmatched )" ; IMMEDIATE : DEFER ( a n a n - a n) #( @ + BEGIN 2OVER NIP OVER >= WHILE 2SWAP DROP , REPEAT ; : PRECEDENCE ( n) >IN @ ' >R >IN ! CONSTANT R> , IMMEDIATE DOES> 2@ DEFER ; : RPN ( n) 0 1 DEFER 2DROP #( @ OR ABORT" Syntax" ; : ?IGNORE #( @ IF 0 1 DEFER 2DROP R> DROP THEN ; : NOTHING ; : START ( - n) 0 #( ! 0 ADDRESS ! ['] NOTHING 0 ARITHMETIC ; \ Variables 06Feb84map: INTEGER VARIABLE IMMEDIATE DOES> [COMPILE] LITERAL ADDRESS @ IF ADDRESS OFF ELSE COMPILE @ THEN ; : (ARRAY) ( a a) SWAP >R 7 DEFER R> [COMPILE] LITERAL ADDRESS @ IF ADDRESS OFF ELSE ['] @ 7 #( @ + 2SWAP THEN ; : [+] ( a i - a) 1- 2* + ; : ARRAY INTEGER 1- 2* ALLOT DOES> ['] [+] (ARRAY) ; : [*+] ( a x y - a) >R 1- OVER @ * R> + 2* + ; : 2ARRAY ( y x) DUP CONSTANT IMMEDIATE * 2* ALLOT DOES> ['] [*+] (ARRAY) ; \ Statement numbers ( works at any address ) 06Feb84map: FIND ( line# -- entry-adr ) TRUE #S @ #S 2+ ?DO OVER I @ ABS = IF 2DROP I FALSE LEAVE THEN 4 +LOOP IF 0 SWAP #S @ 2! #S @ 4 #S +! THEN ; : RESOLVE ( n -- ) FIND DUP @ 0< ABORT" duplicated" DUP @ NEGATE OVER ! 2+ DUP @ BEGIN ?DUP WHILE DUP @ HERE ROT ! REPEAT HERE SWAP ! ; : CHAIN ( n - a) FIND LENGTH 0< IF @ ELSE DUP @ HERE ROT ! THEN ; : STATEMENT ( n -- ) HERE 2- @ >R -4 ALLOT RPN EXECUTE R> RESOLVE START ; \ Branching - high level 13Mar84map : JUMP R> @ >R ; : CALL R> DUP @ SWAP 2+ >R >R ; : SKIP 0= IF R> 4 + >R THEN ; : (NEXT) 2DUP +! >R 2DUP R> @ SWAP 0< IF SWAP THEN - 0< IF 2DROP R> 2+ ELSE R> @ THEN >R ; : [1] COMPILE 1 HERE ; : [NEXT] COMPILE (NEXT) , ; : (GOTO) GET COMPILE JUMP CHAIN , ; : (RET) R> DROP ; \ BASIC 19Jul84map: LET STATEMENT ADDRESS ON ; IMMEDIATE : FOR [COMPILE] LET ; IMMEDIATE : TO RPN DROP ['] [1] 0 ; IMMEDIATE : STEP RPN DROP ['] HERE 0 ; IMMEDIATE : NEXT STATEMENT 2DROP ['] [NEXT] 0 ADDRESS ON ; IMMEDIATE : REM STATEMENT [COMPILE] \ ; IMMEDIATE : DIM [COMPILE] REM ; IMMEDIATE : STOP STATEMENT COMPILE (RET) ; IMMEDIATE : END STATEMENT 2DROP [COMPILE] ; PREVIOUS FORTH ; IMMEDIATE : GOTO STATEMENT (GOTO) ; IMMEDIATE : IF STATEMENT LOGIC ; IMMEDIATE : THEN RPN 0 COMPILE SKIP (GOTO) ; IMMEDIATE : RETURN STATEMENT COMPILE (RET) ; IMMEDIATE : GOSUB STATEMENT GET COMPILE CALL CHAIN , ; IMMEDIATE \ Input and Output 06Feb84map: ASK ." ? " QUERY ; : PUT GET SWAP ! ; : (INPUT) COMPILE PUT ; : (,) ( n) (.) 14 OVER - SPACES TYPE SPACE ; OUTPUTS DEFINITIONS : , ( n) ?IGNORE ['] (,) 1 DEFER ; IMMEDIATE : " [COMPILE] ." 2DROP ; IMMEDIATE INPUTS DEFINITIONS : , ?IGNORE RPN 0 (INPUT) ADDRESS ON ; IMMEDIATE ARITHMETIC DEFINITIONS : PRINT STATEMENT COMPILE CR ['] (,) 1 OUTPUTS ; IMMEDIATE : INPUT STATEMENT 2DROP COMPILE ASK ['] (INPUT) 0 INPUTS ADDRESS ON ; IMMEDIATE \ Operators 06Feb84mapLOGIC DEFINITIONS 2 PRECEDENCE <> 2 PRECEDENCE <= 2 PRECEDENCE >= 2 PRECEDENCE = 2 PRECEDENCE < 2 PRECEDENCE > ARITHMETIC DEFINITIONS : = ( a n) SWAP ! ; 1 PRECEDENCE = : ** ( n n - n) 1 SWAP 1 DO OVER * LOOP * ; 6 PRECEDENCE ABS 5 PRECEDENCE ** 4 PRECEDENCE * 4 PRECEDENCE / 4 PRECEDENCE */ 3 PRECEDENCE + 3 PRECEDENCE - \ [ Dwyer, page 17, Program 1] ( works ) 06Feb84mapINTEGER J INTEGER K : RUN BASIC 10 PRINT " THIS IS A COMPUTER" 20 FOR K = 1 TO 4 30 PRINT " NOTHING CAN GO" 40 FOR J = 1 TO 3 50 PRINT " WRONG" 60 NEXT J 70 NEXT K 80 END RUN \ [ basic: branching demo ] ( works ) 06Feb84mapINTEGER J INTEGER K : RUN BASIC 10 FOR K = 1 TO 15 STEP 3 15 LET J = J + K 20 IF K >= 8 THEN 35 25 PRINT K 30 GOTO 40 35 PRINT K , J , " SUM " 40 NEXT K 50 PRINT " DONE " 80 END RUN \ [ basic: array demo ] ( works ) 06Feb84mapINTEGER K 9 ARRAY COORDINATE : RUN BASIC 10 FOR K = 1 TO 9 20 LET COORDINATE K = ( 10 - K ) ** 3 40 PRINT COORDINATE K + 5 60 NEXT K 80 END RUN \ [ basic string printing demo ] 06Feb84mapINTEGER X INTEGER Y INTEGER Z : RUN BASIC 10 LET X = 5 20 LET Y = 7 30 PRINT X , Y 60 PRINT X , " TEST " 90 END RUN \ [ basic program # 1 ] ( works ) 06Feb84mapINTEGER K INTEGER X 3 ARRAY Z : RUN BASIC 10 LET Z 1 = 1 15 LET Z 2 = 22 20 LET Z 3 = 333 30 FOR K = 1 TO 3 40 LET X = Z K 50 PRINT X 60 NEXT K 80 END RUN \ [ basic inputting demo ] 06Feb84mapINTEGER K INTEGER X INTEGER Y : RUN BASIC 10 INPUT X , Y 20 LET K = X * Y ** 3 40 PRINT X , Y , K 80 END RUN \ [ basic: GOSUB demo ] 19Jul84mapINTEGER K 9 ARRAY COORDINATE : RUN BASIC 10 FOR K = 1 TO 9 20 LET COORDINATE K = 10 - K 30 GOSUB 60 40 NEXT K 50 GOTO 80 60 PRINT COORDINATE K 70 RETURN 80 END