(*
 * LANGUAGE    : ANS Forth
 * PROJECT     : Forth Environments
 * CATEGORY    : Tools, Classic BASIC interpreter
 * AUTHOR      : Lennart Benschop
 * LAST CHANGE : Friday, March 08, 2002 8:01 PM MHX; bug in RIGHT$ (forgot $FF AND in string count mask)
 * LAST CHANGE : August 1, 1993, MHX; added linenums, might be unsafe!!!
 * LAST CHANGE : July 30, 1993, MHX; added F.BASIC , to suppress zero's.
 * LAST CHANGE : June 12, 1993, MHX; Also the UNIMPLEMENTEDs; tForth version
 * LAST CHANGE : June 11, 1993, MHX; Everything seems to work, must test.
 * LAST CHANGE : June 10, 1993, MHX; Variables work, strings have bugs.
 * LAST CHANGE : June 10, 1993, MHX; INTERP and RUN work, but no variables yet.
 * LAST CHANGE : June 7, 1993, Marcel Hendrix; iForth edit.
 * LAST CHANGE : 18:41:30 December 18, 1991, Marcel Hendrix
 *)



	NEEDS -miscutil
	NEEDS -terminal
	NEEDS -streams
	NEEDS -arrays
	NEEDS -graphics

	REVISION -basic "ÄÄÄ BASIC interpreter   Version 1.22 ÄÄÄ"

	PRIVATES


DOC
(*
 Classic BASIC Interpreter.
 A BASIC interpreter as on the early home computers.
 It is slow and unstructured.
 No spaces are necessary between keywords.
 To use this program, knowledge of BASIC is assumed. There is no tutorial.
 Documentation: Vijgeblad #42, 1993.
 
 Bugs
 ----
 SCREEN$ doesn't work in tForth
 #1 doesn't do anything (because there is no general #n).
 May not work correctly if linenumber cache is enabled!
 Files are not binary compatible with Forths having a different FP size.
 (e.g. old iForth has 10 byte floats, new iForth 8 bytes).

 Not in the original specification
 ---------------------------------
 KEYWORD PUT	   \ one str var, may be preceded by #n

 Unimplemented as yet:
 ---------------------
 KEYWORD EDIT	   \ EDIT n
 KEYWORD DEF	   \ DEF FNa(x)=expr Define a user function

 EDIT is not needed when PROCED is active. Just type the linenumber and ^PgDn
 DEF is difficult; what happens to the formal parameter? Is it a global?
*)
ENDDOC


DECIMAL



	-- ** Utilities **


1 FLOATS 3 CELLS > [IF] CR .( Sorry, incompatible format, needs editing.) ABORT
		 [THEN]

MS-DOS?
  [IF] 		: @AT	?AT 2>R AT-XY		\ <x> <y> --- <char>
			 $0800 0 0 0 INT10()	\ BIOS: read char at cursor
			 DROP 2DROP $FF AND
			2R> AT-XY ;
[ELSE]  	: @AT	2DROP '?' ;		\ <x> <y> --- <char>
[THEN]


-- Quoted operators do not need aligned addresses, nor do they need knowledge
-- about big/little endian issues.

CREATE fbu	PRIVATE 1 FLOATS ALLOT

: '@'		fbu =CELL MOVE	fbu @ ;		  \ <addr> --- <n>
: '!'		SWAP fbu ! fbu SWAP =CELL MOVE ;  \ <n> <addr> --- <>
: 'F@'		fbu 1 FLOATS MOVE  fbu F@ ;	  \ <addr> --- <>  F: <> --- <r>
: 'F!'		fbu F!	fbu SWAP 1 FLOATS MOVE ;  \ <addr> --- <n> F: <r> --- <>


		-- ** BASIC tools **


-- Convert a string to a floating-point in-line literal

: F		BL <WORD>  >FLOAT  0= #-4098 ?ERROR" Invalid number?"
		[COMPILE] FLITERAL ;P IMMEDIATE

0 VALUE parseptr  PRIVATE

: DDIGIT?	'0' '9' 1+ WITHIN ;P	\ <char> --- <bool>


-- FCONVERT (leaves a ptr to first unconvertible digit) is missing?

: BFNUMBER	parseptr C@ '-' = 1 AND parseptr +
		BEGIN  C@+ DUP DDIGIT?
		WHILE  DROP
		REPEAT
		DUP  '.' = IF DROP
			      BEGIN C@+ DUP DDIGIT?
			      WHILE DROP
			      REPEAT
			ENDIF
		>UPC 'E' = IF DUP C@  DUP '+' = SWAP '-' = OR 1 AND +
			      BEGIN  C@+ DUP DDIGIT?
			      WHILE  DROP
			      REPEAT DROP
			ENDIF
		1- DUP >S
		  parseptr - parseptr SWAP >FLOAT DROP
		S> TO parseptr ;P


CREATE single-chars  PRIVATE  #256 CHARS ALLOT

: SCFILL	#256 0 DO  I single-chars I + C!  LOOP ;P

SCFILL FORGET SCFILL

#128000 =: memsize PRIVATE	-- Memory space for program and variables.

: ALLOCATER	CREATE	PRIVATE ALLOCATE ?ALLOCATE ,
		FORGET> @ FREE ?ALLOCATE
		DOES>	@ ;P

memsize ALLOCATER memspace

memspace memsize + =: memtop PRIVATE


CREATE keytab PRIVATE	#256 CELLS ALLOT	-- Table of names of keywords.
CREATE ???    PRIVATE	," ?"


-- Fill a part of a table with address w

: WFILL		SWAP 0 ?DO 2DUP SWAP I CELLS + !	\ addr n w ---
		      LOOP 2DROP ;P

keytab #256 ??? WFILL

VOCABULARY KEYWORDS  ' KEYWORDS >BODY =: keyword.wid  PRIVATE

	ALSO KEYWORDS DEFINITIONS

	WARNING @  WARNING OFF



0 VALUE keycntr PRIVATE

: KEYWORD	>IN @
		     keycntr CONSTANT
		>IN !
		BL WORD DUP C@ 1+ ALLOT
		keycntr #255 U> #-4098 ?ERROR" Invalid keyword?"
		keycntr keytab []CELL !
		1 +TO keycntr ;P


#128 TO keycntr	  \ The commands.

KEYWORD PRINT	  \ num or string exprs or TAB(n), separated by ; or ,
		  \ may be preceded by #n
KEYWORD INPUT	  \ one num or str var, may be preceded by #n
KEYWORD GET	  \ one str var, may be preceded by #n
KEYWORD OPENIN	  \ OPENIN a$, Open the single input file #1
KEYWORD OPENOUT	  \ OPENOUT a$, Open the single output file #1
KEYWORD GOTO	  \ GOTO line number.
KEYWORD ON	  \ ON n GOTO linenumbers or ON n GOSUB linenumbers
KEYWORD GOSUB	  \ GOSUB linenumber
KEYWORD RETURN
KEYWORD IF	  \ IF n THEN linenumber or IF n THEN statements
KEYWORD THEN
KEYWORD FOR	  \ FOR var=n1 TO n2, with optional STEP n3
KEYWORD NEXT	  \ NEXT or NEXT var
KEYWORD END	  \ Ends with "Ok" message
KEYWORD STOP	  \ Ends with "Stop" message
KEYWORD CLEAR	  \ Removes all variables.
KEYWORD LET	  \ LET var=n or LET var$=n$, The word LET is optional
KEYWORD REM
KEYWORD READ	  \ num or str var, separated by ,
KEYWORD DATA	  \ num or str expr separated by commas, skipped on execution
KEYWORD RESTORE	  \ Resets data pointer
KEYWORD CLS	  \ clear screen
KEYWORD LOCATE	  \ LOCATE row,col
KEYWORD INVERSE	  \ INVERSE n, where n=0 or 1
KEYWORD BEEP	  \ Make a sound
KEYWORD RANDOMIZE \ RANDOMIZE or RANDOMIZE n. Initialize random numbers.
KEYWORD POKE	  \ POKE addr,n Corrupts your memory
KEYWORD CALL	  \ CALL addr	Hangs your machine
KEYWORD DEF	  \ DEF FNa(x)=expr Define a user function	UNIMPLEMENTED
KEYWORD NEW	  \ Remove program and variable from memory.
KEYWORD LIST	  \ LIST LIST n LIST m-n LIST -n LIST m- all possible
		  \ May be followed by ;A$ to send listing to file.
KEYWORD LOAD	  \ LOAD a$
KEYWORD SAVE	  \ SAVE a$. Program is stored in internal format
KEYWORD RUN	  \ clear variables and start running
KEYWORD CONT	  \ continue after break or STOP command
KEYWORD EDIT	  \ EDIT linenumber
KEYWORD MERGE	  \ MERGE a$ Add the lines to your program, from ASCII file
KEYWORD DELETE	  \ DELETE n, DELETE m-n
KEYWORD BYE	  \ Return to the world of REAL computing.
KEYWORD MODE	  \ MODE 0 or MODE 1 Select text/graphics mode
KEYWORD PLOT	  \ PLOT x,y  plot a single point.
KEYWORD DRAW	  \ DRAW x,y  draw a line.
KEYWORD CLOSEIN	  \ Close the input file
KEYWORD CLOSEOUT  \ CLose the output file
KEYWORD DIM	  \ num or str array variables separated by ,
KEYWORD FILES	  \ Show the directory.
KEYWORD PUT	  \ one str var, may be preceded by #n

#200 TO keycntr

KEYWORD TO
KEYWORD STEP
KEYWORD AND
KEYWORD OR
KEYWORD NOT
KEYWORD <>
KEYWORD <=
KEYWORD <
KEYWORD >=
KEYWORD >
KEYWORD FN

-- The BASIC functions follow.

KEYWORD ABS	\ ABS(n), absolute value
KEYWORD SGN	\ SGN(n), 0,1 or -1 depending on sign.
KEYWORD INT	\ INT(n), round down towards -infinity.
KEYWORD SQR	\ SQR(n), square root.
KEYWORD LOG	\ LOG(n), natural logarithm.
KEYWORD EXP	\ EXP(n), e to the power of n
KEYWORD ATN	\ ATN(n), inverse tangent, in radians.
KEYWORD SIN	\ SIN(n),
KEYWORD COS	\ COS(n)
KEYWORD TAN	\ TAN(n)
KEYWORD LEN	\ LEN(n$), length of n$
KEYWORD ASC	\ ASC(n$), ASCII code of first char, 0 if n$ is empty
KEYWORD CHR$	\ CHR$(n), Single char string with ASCII code n.
KEYWORD LEFT$	\ LEFT$(n$,n)  Left n characters from n$
KEYWORD MID$	\ MID$(n$,m,n) or MID$(n$,m)  Substring starting at m
KEYWORD RIGHT$	\ RIGHT$(n$,n)	Right n characters from n$
KEYWORD UCASE$	\ UCASE$(n$) n$ converted to uppercase.
KEYWORD VAL	\ VAL(n$) convert ASCII string to number.
KEYWORD STR$	\ STR$(n) or STR$(n,w,a) convert n to ASCII, optionally
		\ w indicates the length and a the number of places after .
KEYWORD EOF	\ EOF indicates end of input file.
KEYWORD HPOS	\ HPOS the horizontal position of the cursor
KEYWORD VPOS	\ VPOS the vertical position of the cursor
KEYWORD FREE	\ FREE	The free space in bytes.
KEYWORD SCREEN$ \ SCREEN$(row,col) the character there
KEYWORD PEEK	\ PEEK(addr) The byte stored there.
KEYWORD RND	\ RND gives a different random number every time.
KEYWORD INKEY$	\ INKEY$ the string containing the key pressed, if any
KEYWORD TAB
KEYWORD #1

PREVIOUS  FORTH DEFINITIONS

	WARNING !


DOC
(*
 A BASIC program line consists of:
 - a one cell line number.
 - one cell length in bytes (line number and termination bytes included).
 - The line itself consisting of ASCII characters, keyword codes (>127),
   numeric literals preceded by the byte 01 and counted string literals
   preceded by the byte 02.
 - at least one (1) terminating byte 00.

 The input line is kept in the buffer LINEBUF
 The program lines are kept in memspace.
 The whole program is terminated by an additional null cell.
*)
ENDDOC


-- Type keyword n
: LIST-KW	keytab []CELL @ .$ ;P		\ <n> --- <>


-- Print the BASIC way (as short as possible).

: F.BASIC	FDUP F>D D>F 			\ F: <r> --- <>
		FOVER F= IF  F>D 0 D.R
		       ELSE  0 F.R
		      ENDIF ;P

-- The line pointed to by listptr is listed.
-- Keywords, number literals and string literals are converted back to their
-- original ASCII form.

0 VALUE listptr PRIVATE

: LIST-LINE
	listptr '@' ?DUP IF U. ENDIF	\ Print linenumber.
	2 CELLS +TO listptr		\ Skip linenumber and length.
	BEGIN
	    listptr C@			\ no termination?
	WHILE
	    listptr C@	1 +TO listptr
	    CASE
	     1 OF  listptr 'F@' F.BASIC 1 FLOATS +TO listptr ENDOF
	     2 OF  listptr COUNT '"' EMIT TYPE '"' EMIT
		   listptr C@ 1+  +TO listptr		     ENDOF
		   DUP #127 < IF EMIT ELSE LIST-KW ENDIF
		   0 ( to keep endcase happy)
	    ENDCASE
	REPEAT
	1 +TO listptr
	CR ;P


-- Check if c is a letter.
: ?ALPHA	>UPC DUP  'A' >=  SWAP 'Z' <= AND ;P	\ <c> --- <bool>

-- Check if c is a digit.
: ?DIG		     DUP  '0' >=  SWAP '9' <= AND ;P	\ <c> --- <bool>


DOC
(*
  Compare u characters in two strings. Return 0 if identical.
  The strings are converted to UPPERCASE before the check.

  Note that this mimics the COMPARE definition in F83 / FPC. ANSI's compare
  is case-sensitive and has a different stack diagram.
*)
ENDDOC

-- LPROFILE: 1,500,000 times executed for the Sieve...

\ : UCOMPARE	\ <addr1> <addr2> <u> --- <-0+>
\		SWAP LOCAL ptr2
\		SWAP LOCAL ptr1
\		0 ?DO
\		      ptr1 C@ >UPC
\		      ptr2 C@ >UPC - ?DUP IF UNLOOP EXIT
\				       ENDIF
\		      1 +TO ptr1 ( or: "ptr1 CHAR+ TO ptr1" )
\		      1 +TO ptr2
\		 LOOP
\		0 ;P

: UCOMPARE	\ <addr1> <addr2> <u> --- <-0+>
		BOUNDS
		 ?DO
		        C@+ >UPC
		      I C@  >UPC - ?DUP IF NIP UNLOOP EXIT
				     ENDIF
		LOOP
		DROP 0 ;P


: SCAN-ALPHA
  0
  #256 #128
    DO
	parseptr  I keytab []CELL @ COUNT
	UCOMPARE 0= IF DROP I LEAVE
		 ENDIF
  LOOP
  ?DUP					\ keyword found?
    IF
       DUP listptr C!	1 +TO listptr	\ Store token in line.
       keytab []CELL @ C@ +TO parseptr	\ Point past the keyword.
  ELSE					\ scan a variable name.
       BEGIN
	  parseptr C@
	  DUP  ?ALPHA
	  SWAP ?DIG   OR
       WHILE
	  parseptr C@ listptr C!
	  1 +TO parseptr  1 +TO listptr
       REPEAT
 ENDIF
;P


-- scan for a string literal.

: SCAN-STRLIT
  1 +TO parseptr  1 +TO listptr
  0
  BEGIN
     parseptr C@ DUP '"' <> AND		\ Is end of literal or line reached?
  WHILE
     1+ parseptr C@  listptr C!
     1 +TO parseptr  1 +TO listptr
  REPEAT
  listptr OVER - 1- C!			\ Store count byte in encoded list.
  parseptr C@ IF  1 +TO parseptr
	   ENDIF ;P



CREATE linebuf	PRIVATE		#257 CHARS  3 CELLS +  ALLOT


-- The line pointed to by parseptr is converted to the internal format and
-- stored into linebuf.

: SCAN-ALPHA?	parseptr C@ DUP ?ALPHA	\ <> --- <bool>
		OVER '#' = OR		\ for #1 etc.
		OVER '<' = OR		\ Scan for <= and <>
		SWAP '>' = OR		\ scan for >=
		DUP IF SCAN-ALPHA ENDIF ;P

: SCAN-DIGIT?	parseptr C@ ?DIG  DUP	\ <> --- <bool>
		IF 1 listptr C!	 1 +TO listptr
		   BFNUMBER listptr 'F!' 1 FLOATS +TO listptr
		ENDIF ;P

: SCAN-STRLIT?	parseptr C@ &" = DUP	\ <> --- <bool>
		IF 2 listptr C!	 1 +TO listptr
		   SCAN-STRLIT
		ENDIF ;P

: ENCODE-LINE
  linebuf 2 CELLS + TO listptr
  BEGIN parseptr C@
  WHILE SCAN-ALPHA?
	 0= IF SCAN-DIGIT?
		0= IF SCAN-STRLIT?
			0= IF parseptr C@ listptr C!
			      1 +TO listptr  1 +TO parseptr
			ENDIF
		ENDIF
	 ENDIF
  REPEAT
  0 listptr C!	1 +TO listptr		\ end of line
  0 listptr '!'				\ end of program
    listptr linebuf -  linebuf CELL+ !	\ update count
;P


CREATE cmdtab PRIVATE  #256 CELLS ALLOT \ Table for token execution routines.

: ?SYNTAX #-4098 ?ERROR" Syntax error?" ;P

: ERR	TRUE ?SYNTAX ;P		\ Default for token command.


cmdtab #256 ' ERR WFILL


-- Give the token code of the following word in the input stream.

: TOKEN ( -- c | <token name> )
  BL <WORD> OVER C@ >S	keyword.wid SEARCH-WORDLIST
  ?DUP IF -S >S EXECUTE		\ Found, execute the CONSTANT word.
	     S> 0< IF ILITERAL
		ENDIF		\ not if it is a compiling word!?
     ELSE S> ILITERAL		\ Else give the ASCII code.
    ENDIF ;P IMMEDIATE


: CMD ( | <token> <command> )	\ Attach <command> to keyword.
	[COMPILE] TOKEN
	cmdtab []CELL ' SWAP ! ;P


      0 VALUE iptr	PRIVATE \ Basic instruction pointer.
      0 VALUE curline	PRIVATE \ Currently executed line.
      0 VALUE claddr	PRIVATE \ Address of the currently executed line.
      0 VALUE $ptr	PRIVATE \ Pointer to temporary strings.


: NXT	1 +TO iptr ;P		\ Skip current token.


-- The main loop of the BASIC inner interpreter.
: INTERP
  BEGIN
     ?STACK
     iptr C@
     DUP #200 U>= ?SYNTAX	\ Get the token from instruction stream.
     PAD TO $ptr		\ Initialize string pointer.
     NXT			\ Point to next instruction.
     cmdtab []CELL @EXECUTE	\ Execute its routine.
  AGAIN ;P



: NOOP ;P

' NOOP	BL cmdtab []CELL !	\ Skip spaces.



: ?BREAK	WAIT? #-4098 ?ERROR" Break" ;P

CMD : ?BREAK			\ perform break check at :



VARIABLE TRACE	 TRACE OFF	\ Just for debugging!

: LTERM		?BREAK
		iptr '@' DUP 0= #-4098 ?ERROR" Ok"
		TRACE @ IF DUP U. ENDIF
		TO curline
		iptr TO claddr
		2 CELLS +TO iptr ;P

' LTERM cmdtab !			\ Attach line terminate to null byte.



: SKIP-SPACES	BEGIN  iptr C@ BL =	\ <> --- <>
		WHILE  1 +TO iptr
		REPEAT ;P


-- Check for required token.
: CHK		SKIP-SPACES		\ <c> --- <>
		iptr C@ <> ?SYNTAX NXT ;P



0 VALUE endprog		PRIVATE
0 VALUE endvar		PRIVATE
0 VALUE $start		PRIVATE
0 VALUE dataptr		PRIVATE
0 VALUE dataflag	PRIVATE

#256 CELLS =: bssize	PRIVATE

CREATE bstack  PRIVATE	bssize ALLOT	\ Subroutine stack and FOR-NEXT
0 VALUE bsp    PRIVATE			\ the stack pointer.



-- Decrement BASIC stack pointer by cell.

: BSP-		bsp bstack = #-4098 ?ERROR" Nesting too deep?"
		=CELL NEGATE +TO bsp ;P



: FREE		$start	endvar -  1- 0 MAX ;P		\ <> --- <n>



: DORESTORE	memspace TO dataptr   CLEAR dataflag ;P

CMD RESTORE DORESTORE



: DOCLEAR	endprog CELL+  TO endvar
		0 endvar '!'
		memtop TO $start
		bstack bssize + TO bsp
		DORESTORE ;P

CMD CLEAR DOCLEAR



: DONEW		memspace TO endprog
		0 memspace !
		DOCLEAR ;P

CMD NEW DONEW



-- Find the line with number n
-- LPROFILE says it is 300,000 times executed for the Sieve..

\ : FINDLINE	memspace			\ <n> --- <addr|0>
\		BEGIN
\		   DUP	'@'
\		WHILE
\		   2DUP '@' = IF NIP EXIT ENDIF
\		   DUP CELL+ '@' +
\		REPEAT
\		2DROP 0 ;P

#2000 ARRAY linenums PRIVATE			\ reset by RUN & CONTINUE

: RESETlinenums	'OF linenums SIZEOF linenums ERASE ;P  RESETlinenums

: FINDLINE	DUP linenums 			\ <n> --- <addr|0>
		?DUP IF NIP EXIT ENDIF		\ it was available!
		memspace
		BEGIN
		   DUP	'@'
		WHILE
		   2DUP '@' = IF 2DUP SWAP TO linenums
				 NIP EXIT 
			   ENDIF
		   DUP CELL+ '@' +
		REPEAT
		2DROP 0 ;P


-- Find the line with a number greater than n.

: FINDNEXT	memspace			\ <n> --- <addr>
		BEGIN
		   DUP '@'
		WHILE
		   2DUP '@' U< IF NIP EXIT ENDIF
		   DUP CELL+ '@' +
		REPEAT
		NIP ;P


-- Delete a line from the program.

: DELLINE	DUP CELL+ '@' >S		\ <addr> --- <>
		DUP  S +			\ ai	ai+1
		TUCK				\ ai+1	ai   ai+1
		endprog SWAP -	CMOVE		\ may NOT fill!
		S> NEGATE +TO endprog
		0 endprog '!' ;P


-- Allocate n bytes of program memory.

: ALLOT-P	endprog + DUP			\ <n> --- <>
		memtop 2 CELLS - U< 0= #-4098 ?ERROR" Out of memory!"
		TO endprog ;P


-- Insert the line in linebuf into program.

: INSLINE	linebuf CELL+ @ >S		\ <addr> --- <>
		DUP				\ ai  ai
		DUP S +				\ ai  ai  ai+1
		OVER endprog SWAP -		\ ai  ai  ai+1	ep-ai
		S ALLOT-P CMOVE>		\ ai  ( no filling!)
		linebuf SWAP S> CMOVE
		0  endprog  '!' ;P


: MERGE-LINE	linebuf @ FINDLINE
		?DUP IF DELLINE
		  ENDIF
		linebuf 2 CELLS +
		    C@ IF linebuf @ FINDNEXT
			  INSLINE
		    ENDIF
		DOCLEAR ;P


CREATE inputbuffer  PRIVATE	#261 CHARS ALLOT

: BASIC-RUN
  BEGIN
     inputbuffer #256 ACCEPT  CR
     0 OVER inputbuffer + '!'
  WHILE
     0. inputbuffer 1- CONVERT TO parseptr  DROP  linebuf !
     parseptr C@ BL = IF  1 +TO parseptr  ENDIF	 ( skip blanks?)
     ENCODE-LINE
     linebuf @ IF  MERGE-LINE
	     ELSE  CLEAR curline
		   linebuf TO claddr
		   linebuf 2 CELLS + TO iptr
		   INTERP
	    ENDIF
  REPEAT ;P


: BASIC?ERR ( flag -- )
  ?DUP IF  CR curline
	      IF DUP
		 CASE
		  #-4097 OF ." Fatal error in line " curline DEC. THROW	  ENDOF
		  #-4098 OF DROP '[' EMIT curline 0 .R ." ] " 'ERRM$ @ .$ ENDOF
			    DUP THROW
		 ENDCASE
	    ELSE DUP
		 CASE
		  #-4097 OF ." Fatal error in BASIC!" THROW   ENDOF
		  #-4098 OF 'ERRM$ @ .$			      ENDOF
			    DUP THROW
		 ENDCASE
	   ENDIF
	   CR
	   SP0	@ SP!
	   FSP0 @ FSP!
    ENDIF ;P


0 VALUE leave?	PRIVATE

: BASIC		6 SET-PRECISION
		endprog 0= IF  DONEW  ENDIF
		CLS ." Classic BASIC interpreter."
		CR FREE U. ." bytes free."
		CR
		CLEAR leave?
		BEGIN
		  ['] BASIC-RUN CATCH BASIC?ERR
		  leave?
		UNTIL ;


: DOBYE		TRUE TO leave? ;P

CMD BYE DOBYE


0 VALUE minline PRIVATE
0 VALUE maxline PRIVATE

: DOLIST
  SKIP-SPACES iptr C@
	1 = IF	1 +TO iptr  iptr 'F@' 1 FLOATS +TO iptr	 F>S TO minline
	  ELSE	CLEAR minline
	 ENDIF
  SKIP-SPACES iptr C@ TOKEN -
   = IF NXT  SKIP-SPACES iptr C@
	1 = IF	1 +TO iptr  iptr 'F@' 1 FLOATS +TO iptr	 F>S TO maxline
	  ELSE -1 +TO maxline
	 ENDIF
   ELSE minline 0= IF  -1  ELSE	 minline  ENDIF	 TO maxline
  ENDIF
  memspace TO listptr
  BEGIN
     listptr '@'
  WHILE
     listptr '@'  DUP minline U>=
     SWAP maxline  U<= AND
       IF LIST-LINE
     ELSE listptr CELL+ '@' +TO listptr
    ENDIF
  REPEAT ;P

CMD LIST DOLIST


: DORUN		DOCLEAR RESETlinenums
		memspace TO iptr
		LTERM ;P

CMD RUN DORUN


: DOCONT	RESETlinenums
		curline FINDNEXT TO iptr
		LTERM ;P

CMD CONT DOCONT


DOC
(*
 A BASIC variable consists of:
 - a cell indicating its overall length (everything included).
 - a byte indicating its type. (0=numeric, 1=string, 2=num array, 3=str array
    4=user function.)
 - a counted string indicating its name (without the dollar sign).
 - type dependent contents.

 Program variables are kept in memspace, from endprog+cell to endvar
 After that a null cell is appended.
*)
ENDDOC


CREATE vnbuffer	 PRIVATE  #258 CHARS ALLOT -- Search buffer for variable name.

-- Store the ASCII string of the name in buffer.
-- byte 0 = type, 1 = count, rest = chars

: SCAN-VNAME	vnbuffer 2+ TO parseptr
		BEGIN
		   iptr C@ DUP ?ALPHA
		   OVER ?DIG OR
		WHILE
		   parseptr C!
		   1 +TO iptr
		   1 +TO parseptr
		REPEAT
		DROP
		parseptr vnbuffer 2+ - vnbuffer 1+ C! ;P


-- Scan the variable name and determine its type.

: PARSE-VNAME	iptr C@ TOKEN FN =
		   IF 1 +TO iptr
		      SCAN-VNAME
		      4 vnbuffer C!		\ user function
		 ELSE SCAN-VNAME
		      0 vnbuffer C!		\ assume numeric variable
		      iptr C@ TOKEN $ =
			   IF  1 vnbuffer C+!	\ string or string array
			       1 +TO iptr
			ENDIF
			iptr C@ TOKEN ( =
			   IF  2 vnbuffer C+!	\ numeric or numeric array
			       1 +TO iptr
			ENDIF
		ENDIF ;P


-- Find the next variable in the instruction stream.

: FINDVAR
		PARSE-VNAME			\ <> --- <addr|0>
		endprog CELL+
		BEGIN
		   DUP '@'
		WHILE				\ v-- compare length and type
		   DUP CELL+  vnbuffer DUP  1+ C@ 2+
		   UCOMPARE 0=	IF EXIT ENDIF
		   DUP '@' +
		REPEAT
		DROP 0 ;P


DOC
(*
 Strings are kept in memspace from $start to MEMTOP. Strings are
 allocated from top to bottom. Each string is followed by a
 back pointer to a 2-cell string descriptor. This string descriptor
 is stored in the variable space. It consists of a one cell address
 and a one-cell length (contents of this cell < 256 though).

 When a string is no longer needed, its back pointer is replaced with
 the length (<=255). When memory must be cleared up, all strings
 with a valid back pointer are moved toward the top of memory. The
 thrown-away strings are then overwritten.
*)
ENDDOC


0 VALUE gc-source	PRIVATE \ source address of a string that may be moved.
0 VALUE gc-dest		PRIVATE \ destination address for the move


: GARBAGE-COLLECT		\ Clear up memory.
  memtop
  DUP TO gc-source
      TO gc-dest		\ Start at the top.
  BEGIN
     gc-source	$start <>	\ proceed until bottom of string space.
  WHILE
     =CELL NEGATE +TO gc-source
     gc-source '@'		\ Get back pointer from string.
     DUP #256 U<
       IF			\ Is string erased?
	NEGATE +TO gc-source	\ Then decrement source till next string
     ELSE
	DUP >S CELL+ C@		\ Get length from string variable.
	DUP NEGATE
	DUP +TO gc-source
	CELL- +TO gc-dest	\ Update pointers.
	gc-source  gc-dest ROT CMOVE>	\ Move the string.
	gc-dest S !		\ Set address in variable to new string address
	S> DUP CELL+ C@
	gc-dest + '!'		\ Update back pointer.
    ENDIF
  REPEAT
  gc-dest TO $start ;P		\ Dest points to bottom of string space.


-- Allocate n bytes of variable space.

: ALLOT-V	endvar + DUP	\ <n> --- <>
		$start CELL- U>=
		   IF  GARBAGE-COLLECT
		       DUP $start CELL- U>= #-4098 ?ERROR" Out of memory!"
		ENDIF
		TO endvar ;P


-- Find or create the variable.

1 CHARS CELL+  #11 2* CELLS + =: /$arr	PRIVATE -- default: 11 strings in array
1 CHARS CELL+  #11 FLOATS   + =: /#arr	PRIVATE -- default: 11 floats in array

: FIND&MAKEVAR ( -- addr )
   FINDVAR
   ?DUP IF  EXIT  ENDIF
   endvar
    vnbuffer 1+ C@ 2+ CELL+ ALLOT-V
    vnbuffer  OVER CELL+  vnbuffer 1+ C@ 2+  CMOVE \ Create its name.
    vnbuffer C@
    CASE
      0 OF endvar 1 FLOATS  ALLOT-V 1 FLOATS ERASE ENDOF ( numeric)
      1 OF endvar 2 CELLS   ALLOT-V 2 CELLS  ERASE ENDOF ( string)
      2 OF endvar DUP /#arr ALLOT-V /#arr ERASE 1 OVER C! #10 SWAP 1+ '!' ENDOF
      3 OF endvar DUP /$arr ALLOT-V /$arr ERASE 1 OVER C! #10 SWAP 1+ '!' ENDOF
    ENDCASE
   endvar OVER - OVER '!'	\ Set length of variable.
   0 endvar '!' ;P		\ Set end marker.


DEFER SCAN-EXPR PRIVATE

: ?NUM ( t -- )	   	      #-4098 ?ERROR" String number mismatch?" 		;P
: ?STR ( addr count t -- ) 0= #-4098 ?ERROR" String number mismatch?" $FF AND 	;P


DOC Arrays
(*
 The first byte contains the number of dimensions.
 The next CELLs contains the upper bounds of the various subscripts.
 After this, we get the string descriptors or floats (elements).
 String arrays	: each element is built like a normal string (2 cells)
 Numeric arrays : each element is built like a normal float (1 floats)

 For multi-dimensional arrays:
 [dims.byte] [sub1max.cell] ... [subNmax.cell] <element1>...<elementN>
*)
ENDDOC


: VAR-ADDR ( -- addr type )
  FIND&MAKEVAR
    DUP	 CELL+ C@ ( type)
    SWAP CELL+ 1+ DUP C@ 1+ + ( point after the name)
  SWAP
  DUP 1 AND >S
  2 AND
  IF							\ Is it an array?
   1+ CELL+
   SCAN-EXPR ?NUM F>S					\ Get first subscript
   2DUP SWAP CELL- '@' U> #-4098 ?ERROR" Subscript!"	\ Check bound
   OVER CELL- 1- C@ 1-
	0 ?DO			\ And for all remaining subscripts (1..n)
	      OVER '@' 1+ *	\ subscripts start at 0..m-1
	      TOKEN , CHK
	      SWAP CELL+ SWAP	\ address, cumulative_index
	      SCAN-EXPR ?NUM F>S
	      2 PICK OVER SWAP CELL- '@' U> #-4098 ?ERROR" Subscript wrong!" +
	 LOOP
   TOKEN ) CHK
    S IF  CELLS	 2* ( strings need 2 cells )
    ELSE  FLOATS
   ENDIF
   +
  ENDIF
  S> ;P


: SCAN-ATOM ( f: -- r, -- 0 )  ( -- addr n 1 )
  SKIP-SPACES iptr C@ TOKEN - = IF TRUE NXT ELSE FALSE ENDIF >S
  SKIP-SPACES iptr C@ DUP 1 =
    IF DROP iptr 1+ 'F@' 1 FLOATS 1+ +TO iptr 0
  ELSE DUP ?ALPHA IF DROP VAR-ADDR 0= IF 'F@' 0 ELSE DUP '@' SWAP CELL+ C@ 1 THEN
  ELSE DUP TOKEN ( = IF DROP 1 +TO iptr	 SCAN-EXPR TOKEN ) CHK
  ELSE DUP 2 = IF DROP 1 +TO iptr  iptr COUNT 2DUP + TO iptr 1
  ELSE DUP #200 > IF NXT cmdtab []CELL @EXECUTE
  ELSE DROP TRUE ?SYNTAX
  ENDIF ENDIF ENDIF ENDIF ENDIF
  S> IF ?NUM FNEGATE 0 ENDIF
;P


: SCAN-FACTOR
  SKIP-SPACES iptr C@ TOKEN - = IF TRUE NXT ELSE FALSE ENDIF >S
  SCAN-ATOM
  DUP 0=
     IF	  BEGIN
	     SKIP-SPACES iptr C@ TOKEN ^ =
	  WHILE
	     NXT SCAN-ATOM ?NUM F**
	  REPEAT
  ENDIF
  S> IF ?NUM FNEGATE 0
  ENDIF ;P

: SCAN-TERM
  SCAN-FACTOR
  DUP 0<> IF EXIT ENDIF
  BEGIN
     SKIP-SPACES iptr C@
     CASE TOKEN * OF 1 +TO iptr SCAN-FACTOR ?NUM F* TRUE   ENDOF
	  TOKEN / OF 1 +TO iptr SCAN-FACTOR ?NUM F/ TRUE   ENDOF
		     FALSE SWAP
     ENDCASE
     0=
  UNTIL ;P


-- Store the string into buffer and increment pointer.

: $>TEMP	$ptr SWAP DUP +TO $ptr CMOVE ;P \ <addr> <len> --- <>


: SCAN-SEXPR
  SCAN-TERM
  DUP 0= IF
	  BEGIN
	     SKIP-SPACES iptr C@
	     CASE TOKEN + OF 1 +TO iptr SCAN-TERM ?NUM F+ TRUE	 ENDOF
		  TOKEN - OF 1 +TO iptr SCAN-TERM ?NUM F- TRUE	 ENDOF
			     FALSE SWAP
	     ENDCASE
	     0=
	  UNTIL
  ELSE
     SKIP-SPACES iptr C@ TOKEN + =
	IF \ Concatenate the strings in a temporary buffer.
	   DROP $ptr >S $>TEMP
	   BEGIN
	      NXT $ptr SCAN-TERM ?STR ROT TO $ptr $>TEMP
	      SKIP-SPACES iptr C@ TOKEN + <>
	   UNTIL
	   S> $ptr OVER - DUP #255 > #-4098 ?ERROR" String too long!" 1
     ENDIF
 ENDIF ;P


: B>F		    IF F -1		\ F: <> --- <r>	 <f> --- <>
		  ELSE F  0
		 ENDIF ;P


: $-		ROT SWAP 2DUP - >S MIN	\ addr1 n1 addr2 n2 -- f
		TUCK COMPARE DUP 0= IF DROP S
				 ENDIF
		-S ;P


: SCAN-LFACTOR
  SKIP-SPACES iptr C@ TOKEN NOT = IF NXT TRUE ELSE FALSE ENDIF >S
  SCAN-SEXPR
  DUP 0= IF
   SKIP-SPACES iptr C@
   CASE
    TOKEN  < OF NXT SCAN-SEXPR ?NUM F<	      B>F ENDOF
    TOKEN  > OF NXT SCAN-SEXPR ?NUM F>	      B>F ENDOF
    TOKEN  = OF NXT SCAN-SEXPR ?NUM F=	      B>F ENDOF
    TOKEN >= OF NXT SCAN-SEXPR ?NUM F< INVERT B>F ENDOF
    TOKEN <= OF NXT SCAN-SEXPR ?NUM F> INVERT B>F ENDOF
    TOKEN <> OF NXT SCAN-SEXPR ?NUM F= INVERT B>F ENDOF
   ENDCASE
  ELSE
   DROP
   SKIP-SPACES iptr C@
   CASE
    TOKEN  < OF NXT SCAN-SEXPR ?STR $- 0<  B>F 0 ENDOF
    TOKEN  > OF NXT SCAN-SEXPR ?STR $- 0>  B>F 0 ENDOF
    TOKEN  = OF NXT SCAN-SEXPR ?STR $- 0=  B>F 0 ENDOF
    TOKEN >= OF NXT SCAN-SEXPR ?STR $- 0>= B>F 0 ENDOF
    TOKEN <= OF NXT SCAN-SEXPR ?STR $- 0<= B>F 0 ENDOF
    TOKEN <> OF NXT SCAN-SEXPR ?STR $- 0<> B>F 0 ENDOF
		1 SWAP
   ENDCASE
  ENDIF
  S> IF ?NUM F>D INVERT SWAP INVERT SWAP D>F 0 ENDIF
;P


: SCAN-LTERM
  SCAN-LFACTOR
  DUP IF EXIT ENDIF
   BEGIN
      SKIP-SPACES iptr C@ TOKEN AND =
   WHILE
      NXT SCAN-LFACTOR ?NUM
      F>D F>D ROT AND SWAP ROT AND SWAP D>F
   REPEAT ;P

: SCAN-LEXPR
  SCAN-LTERM
  DUP IF  EXIT ENDIF
   BEGIN
      SKIP-SPACES iptr C@ TOKEN OR =
   WHILE
      NXT SCAN-LTERM ?NUM
      F>D F>D ROT OR SWAP ROT OR SWAP D>F
   REPEAT ;P

' SCAN-LEXPR IS SCAN-EXPR



-- Allot n bytes of string space.

: $ALLOT ( n -- )
   $start OVER - endvar CELL+ U<
     IF
       GARBAGE-COLLECT
       $start OVER - endvar CELL+ U< #-4098 ?ERROR" Out of memory!"
  ENDIF
  NEGATE +TO $start
;P


-- Store the string addr1 n at addr2

: $!					\ <addr1> <n> <addr2> --- <>
  DUP @ endprog U>=			\ Is old string in string space?
     IF
       DUP CELL+ C@ OVER '@' OVER + '!' \ Store its length in its back pointer
					\ to invalidate it.
  ENDIF
  >S
  OVER memspace endprog WITHIN
    IF				\ String is in a safe place?
				\ (in program or single char tab?)
      S CELL+ C!		\ Store length
      S> '!'			\ Store start.
  ELSE				\ String must be stored in string space.
      DUP -ROT $>TEMP
	$ptr OVER - SWAP	\ Move string to buffer.
      DUP CELL+ $ALLOT
      $start SWAP DUP >S CMOVE	\ Move it to string space.
      S> DUP S CELL+ C!		\ Store length.
      S SWAP $start + '!'	\ Store back pointer.
      $start S> '!'		\ Store start.
 ENDIF ;P



: DOPRINT
  1				\ The goto new line flag.
  BEGIN
     SKIP-SPACES iptr C@
     DUP TOKEN : <> AND		\ Not reached statement end?
  WHILE
     iptr C@ DUP TOKEN ; = IF 2DROP 0 NXT
     ELSE DUP TOKEN ,	 = IF 2DROP 0 NXT ?AT DROP 1- #15 AND #15 SWAP - SPACES
     ELSE     TOKEN TAB	 = IF DROP 0 NXT TOKEN (  CHK  SCAN-EXPR ?NUM
			      F>S C/L 1- MIN ?AT NIP AT-XY TOKEN ) CHK
     ELSE DROP 1 SCAN-EXPR IF TYPE  ELSE  F.BASIC  ENDIF
     ENDIF ENDIF ENDIF
  REPEAT
  IF CR ENDIF ;P

CMD PRINT DOPRINT
CMD ? DOPRINT


: (DOLET)	-1 +TO iptr
		SKIP-SPACES
		VAR-ADDR
		TOKEN = CHK
		   IF SCAN-EXPR ?STR ROT $!
		 ELSE SCAN-EXPR ?NUM 'F!'
		ENDIF ;P


'A' cmdtab []CELL #26 ' (DOLET) WFILL
'a' cmdtab []CELL #26 ' (DOLET) WFILL


-- Lines starting with a variable are LET statements

: DOLET		1 +TO iptr  (DOLET) ;P

CMD LET DOLET


-- Skip to next line.
: SKIPTONEXT	claddr DUP CELL+ '@' + TO iptr
		LTERM ;P

CMD REM	 SKIPTONEXT
CMD DATA SKIPTONEXT


: DOGOTO	SKIP-SPACES
		iptr C@ 1 <> ?SYNTAX
		iptr 1+ 'F@' F>S
		FINDLINE
		DUP 0= #-4098 ?ERROR" Invalid line number?"
		TO iptr LTERM ;P

CMD GOTO DOGOTO


: DOIF		SCAN-EXPR ?NUM
		TOKEN THEN CHK
		F0= IF SKIPTONEXT
		  ELSE SKIP-SPACES iptr C@ 1 = IF  DOGOTO  ENDIF
		 ENDIF ;P

CMD IF DOIF

CMD CLS CLS


: DOSTOP	TRUE #-4098 ?ERROR" Stop" ;P	CMD STOP DOSTOP
: DOEND		TRUE #-4098 ?ERROR" Ok"	  ;P	CMD END	 DOEND


CREATE PROGFILE	 PRIVATE  #128 CHARS ALLOT

: STORE-FNAME	SCAN-EXPR ?STR	PROGFILE PACK DROP ;P


: DOLOAD	STORE-FNAME
		PROGFILE COUNT R/O OPEN-FILE #-4098 ?ERROR" Can't open."
		  LOCAL handle
		memspace memsize 2 CELLS - handle READ-FILE
		#-4098 ?ERROR" Can't read." ( count)
		handle CLOSE-FILE #-4098 ?ERROR" Can't close."
		memspace + TO endprog
		0 endprog '!'
		DOCLEAR ;P

CMD LOAD DOLOAD


: DOSAVE	STORE-FNAME
		PROGFILE COUNT R/W CREATE-FILE #-4098 ?ERROR" Can't create."
		  LOCAL handle
		memspace endprog OVER - handle WRITE-FILE
		#-4098 ?ERROR" Can't write."
		handle CLOSE-FILE #-4098 ?ERROR" Can't close." ;P

CMD SAVE DOSAVE

CREATE rbuffer	PRIVATE	  #261 CHARS ALLOT

: DOMERGE	SCAN-EXPR ?STR R/O OPEN-FILE #-4098 ?ERROR" Can't find."
		  LOCAL handle
		BEGIN
		     rbuffer #256 handle READ-LINE #-4098 ?ERROR" Can't read."
		WHILE
		     CR rbuffer OVER TYPE
		     0. rbuffer CONVERT TO parseptr DROP linebuf !
		     parseptr C@ BL = IF 1 +TO parseptr ENDIF
		     ENCODE-LINE
		     linebuf @ IF MERGE-LINE ENDIF
		REPEAT
		handle CLOSE-FILE #-4098 ?ERROR" Can't close."
		TRUE #-4097 ?ERROR" Ok" ;P

CMD MERGE DOMERGE


: DOGOSUB	SKIP-SPACES
		iptr C@ 1 <> ?SYNTAX
		iptr 1+ 'F@' F>S  1 FLOATS 1+ +TO iptr
		FINDLINE
		DUP 0= #-4098 ?ERROR" Invalid line number?"
		BSP- BSP- BSP- BSP-
		1	bsp	      !		\ GOSUB marker
		iptr	bsp   CELL+   !
		curline bsp 2 CELLS + !
		claddr	bsp 3 CELLS + !
		TO iptr	 LTERM ;P

CMD GOSUB DOGOSUB


: DORETURN	bsp @ 1 <> #-4098 ?ERROR" RETURN without GOSUB"
		bsp   CELL+   @ TO iptr
		bsp 2 CELLS + @ TO curline
		bsp 3 CELLS + @ TO claddr
		4 CELLS +TO bsp	 ;P

CMD RETURN DORETURN


-- Here we assume 1 FLOATS is smaller than 3 CELLS

: DOFOR		SKIP-SPACES VAR-ADDR ?NUM DUP
		TOKEN = CHK
		SCAN-EXPR ?NUM 'F!'
		TOKEN TO CHK
		SCAN-EXPR ?NUM
		SKIP-SPACES iptr C@ TOKEN STEP
		 = IF NXT SCAN-EXPR ?NUM
		 ELSE F 1
		ENDIF
		#11 0 DO BSP- LOOP
		=CELL	  bsp		!
		iptr	  bsp	CELL+	!
		curline	  bsp 2 CELLS + !
		claddr	  bsp 3 CELLS + !
			  bsp 4 CELLS + !	\ The variable address.
			  bsp 5 CELLS + F!	\ The step.
			  bsp 8 CELLS + F!	\ The limit.
		;P

CMD FOR DOFOR


-- Here we again assume 1 FLOATS is smaller than 3 CELLS

: DONEXT
  SKIP-SPACES iptr C@ ?ALPHA
     IF	 VAR-ADDR ?NUM bsp 4 CELLS + @ <> #-4098 ?ERROR" NEXT without FOR"
  ENDIF
  bsp @ =CELL <> #-4098 ?ERROR" NEXT without FOR"
  bsp 5 CELLS + F@
  bsp 4 CELLS + @ 'F@' F+
  bsp 4 CELLS + @ 'F!'			\ Increment variable.
  bsp 4 CELLS + @ 'F@'
  bsp 8 CELLS + F@
  bsp 5 CELLS + F@ F0<
     IF	 F< 0=
   ELSE	 F> 0=
  ENDIF					\ Compare to limit.
    IF	bsp   CELL+   @ TO iptr		\ Loop back.
	bsp 2 CELLS + @ TO curline
	bsp 3 CELLS + @ TO claddr
  ELSE	#11 CELLS +TO bsp		\ Get rid of stuff on the stack.
 ENDIF ;P

CMD NEXT DONEXT


: DOINPUT	SKIP-SPACES VAR-ADDR
		PAD #255 BL FILL
		." ?" PAD #255 EXPECT CR
		    IF	PAD SPAN @ ROT $!
		  ELSE	PAD TO parseptr	 BFNUMBER 'F!'
		 ENDIF ;P

CMD INPUT DOINPUT


: DODIM
  -1 +TO iptr
  BEGIN
   NXT
   SKIP-SPACES FINDVAR #-4098 ?ERROR" Redimensioning array?"
   vnbuffer C@ DUP >S  2 AND 0= ?SYNTAX		\ type [2,3] to S
   endvar
   vnbuffer 1+ C@ 3 + CELL+ ALLOT-V		\ /total,type,cnt,name,#dims
   vnbuffer OVER CELL+ vnbuffer 1+ C@ 2+ CMOVE	\ Create its name.
   0 endvar 1- C!				\ initially 0 dimensions.
   -1 +TO iptr endvar 1- 1			\ dim.addr, totsize
   BEGIN
    NXT OVER DUP C@ 1+ SWAP C!			\ Increment dimension count.
    SCAN-EXPR ?NUM F>S				\ Get next dimension.
    =CELL ALLOT-V DUP endvar CELL- '!'		\ Store it.
    ( maxsubscript) 1+ UM* #-4098 ?ERROR" Out of memory!" \ Allow no overflow.
    SKIP-SPACES iptr C@ TOKEN , <>
   UNTIL
   NIP ( dim.addr)
   S> 3 = IF  2 CELLS				\ string array
	ELSE  1 FLOATS				\ numeric array
       ENDIF  UM* #-4098 ?ERROR" Out of memory!"
   endvar SWAP DUP ALLOT-V ERASE		\ Create and clear the space.
   0 endvar '!'
   endvar OVER - SWAP '!'			\ Set length of variable.
   TOKEN ) CHK
   SKIP-SPACES iptr C@ TOKEN , <>
  UNTIL
;P

CMD DIM DODIM


0 VALUE inhibit-data	PRIVATE

-- Dataflag=FALSE, Dataptr points to start of (first) line.

: SEARCH-DATA
  BEGIN
     CLEAR inhibit-data
     dataptr '@' 0= #-4098 ?ERROR" Out of data?"
     2 CELLS +TO dataptr
      BEGIN
	dataptr C@ DUP 1 +TO dataptr
	CASE
	 TOKEN DATA OF inhibit-data 0= IF DROP EXIT ENDIF ENDOF
	     1	    OF	1 FLOATS +TO dataptr		  ENDOF \ Skip literals
	     2	    OF	dataptr C@ 1+ +TO dataptr	  ENDOF \ Skip strings
	 TOKEN REM  OF	TRUE TO inhibit-data		  ENDOF
	ENDCASE
	0=
      UNTIL
  AGAIN ;P


: DOREAD
  -1 +TO iptr
  BEGIN
     NXT
     SKIP-SPACES VAR-ADDR ( addr type)
     dataflag 0= IF  SEARCH-DATA  ENDIF
     iptr >S dataptr TO iptr
	IF  SCAN-EXPR ?STR ROT $!
      ELSE  SCAN-EXPR ?NUM 'F!'
     ENDIF
     SKIP-SPACES iptr C@ TOKEN , = IF NXT TRUE ELSE SKIP-SPACES NXT 0 ENDIF
     TO dataflag
     iptr TO dataptr
     S> TO iptr
     SKIP-SPACES iptr C@ TOKEN , <>
  UNTIL ;P

CMD READ DOREAD


: DOON
  0					\ The found-flag, set to FALSE
  SCAN-EXPR ?NUM F>S
  SKIP-SPACES iptr C@ >S
  1					\ Item-counter.
  BEGIN
   NXT SKIP-SPACES 1 CHK
   2DUP = IF
	     DROP NIP TRUE
	     SWAP DUP			\ Set found-flag.
	     iptr 'F@'			\ Get line number.
       ENDIF
   1 FLOATS +TO iptr			\ Skip line number
   1+ SKIP-SPACES iptr C@ TOKEN , <>
  UNTIL
  2DROP
  IF
   S> DUP TOKEN GOSUB
    = IF
	DROP
	BSP- BSP- BSP- BSP-
	1 bsp !				\ GOSUB marker
	iptr	bsp   CELL+   !
	curline bsp 2 CELLS + !
	claddr	bsp 3 CELLS + !
    ELSE
	TOKEN GOTO <> ?SYNTAX
   ENDIF
      F>S FINDLINE DUP 0= #-4098 ?ERROR" Invalid line?"
      TO iptr LTERM
  ELSE
    -S
  ENDIF ;P

CMD ON DOON


0 VALUE rseed	PRIVATE

: DORANDOMIZE	SKIP-SPACES
		iptr C@ DUP TOKEN : <> AND
		   IF  SCAN-EXPR ?NUM F>S
		 ELSE  TIME NIP NIP
		ENDIF
		TO rseed ;P

CMD RANDOMIZE DORANDOMIZE


: DOFILES	DIR ;P

CMD FILES DOFILES


: DOLOCATE	SCAN-EXPR ?NUM F>S
		TOKEN , CHK
		SCAN-EXPR ?NUM F>S
		C/L 1- UMIN SWAP L/SCR 1- UMIN AT-XY ;P

CMD LOCATE DOLOCATE


: DOBEEP	^G EMIT ;P

CMD BEEP DOBEEP


: DOPOKE	SCAN-EXPR ?NUM F>S
		TOKEN , CHK
		SCAN-EXPR ?NUM F>S
		SWAP C! ;P

CMD POKE DOPOKE


: DOCALL	SCAN-EXPR ?NUM F>S
		['] EXIT SWAP EXECUTE ;P

CMD CALL DOCALL


-- The BASIC functions that are called from the evaluator.

: DOABS		TOKEN ( CHK
		  SCAN-EXPR ?NUM
		  FABS 0
		TOKEN ) CHK ;P

CMD ABS DOABS



S" MAX-UD" ENVIRONMENT? DROP D>F FCONSTANT fmaxint  PRIVATE

: DOINT
  TOKEN ( CHK
  SCAN-EXPR ?NUM
  FDUP FABS fmaxint
  F< IF
	   FDUP F0<
	     IF	 FDUP FABS F>D D>F F 1 F+ FSWAP FOVER F+ F>D D>F FSWAP F-
	   ELSE	 F>D D>F
	  ENDIF
  ENDIF 0
  TOKEN ) CHK ;P

CMD INT DOINT


: DOSGN		TOKEN ( CHK
		  SCAN-EXPR ?NUM
		  FDUP F0< IF FDROP F -1
			 ELSE F0= IF F 0
				ELSE F 1
			       ENDIF
			ENDIF 0
		TOKEN ) CHK ;P

CMD SGN DOSGN


: DOSQR		TOKEN ( CHK
		    SCAN-EXPR ?NUM
		    FSQRT 0
		TOKEN ) CHK ;P

CMD SQR DOSQR


: DOSIN		TOKEN ( CHK
		    SCAN-EXPR ?NUM
		    FSIN 0
		TOKEN ) CHK ;P

CMD SIN DOSIN


: DOCOS		TOKEN ( CHK
		    SCAN-EXPR ?NUM
		    FCOS 0
		TOKEN ) CHK ;P

CMD COS DOCOS


: DOTAN		TOKEN ( CHK
		    SCAN-EXPR ?NUM
		    FTAN 0
		TOKEN ) CHK ;P

CMD TAN DOTAN


: DOATN		TOKEN ( CHK
		    SCAN-EXPR ?NUM
		    FATAN 0
		TOKEN ) CHK ;P

CMD ATN DOATN


: DOEXP		TOKEN ( CHK
		    SCAN-EXPR ?NUM
		    FEXP 0
		TOKEN ) CHK ;P

CMD EXP DOEXP


: DOLOG		TOKEN ( CHK
		    SCAN-EXPR ?NUM
		    FLN 0
		TOKEN ) CHK ;P

CMD LOG DOLOG


: DOLEN		TOKEN ( CHK
		    SCAN-EXPR ?STR
		    NIP S>F 0
		TOKEN ) CHK ;P

CMD LEN DOLEN


: DOASC		TOKEN ( CHK
		    SCAN-EXPR ?STR
		    IF C@ ELSE 0 ENDIF S>F 0
		TOKEN ) CHK ;P

CMD ASC DOASC


: DOCHR$	TOKEN ( CHK
		    SCAN-EXPR ?NUM
		    F>S #255 AND single-chars + 1 1
		TOKEN ) CHK ;P

CMD CHR$ DOCHR$


: DOFREE	GARBAGE-COLLECT FREE S>F 0 ;P

CMD FREE DOFREE


: DOLEFT$	TOKEN ( CHK
		    SCAN-EXPR ?STR
		    TOKEN , CHK
		    SCAN-EXPR ?NUM F>S #255 AND  MIN 1
		TOKEN ) CHK ;P

CMD LEFT$ DOLEFT$


: DORIGHT$	TOKEN ( CHK
		   SCAN-EXPR ?STR 
		   TOKEN , CHK
		   SCAN-EXPR ?NUM F>S  #255 AND 
		   OVER MIN >S
		   S - + S>  1
		TOKEN ) CHK ;P

CMD RIGHT$ DORIGHT$


: DOMID$
  TOKEN ( CHK
    SCAN-EXPR ?STR
    TOKEN , CHK
    SCAN-EXPR ?NUM F>S #255 AND
    SKIP-SPACES iptr C@ TOKEN ,
     = IF NXT SCAN-EXPR ?NUM F>S #255 AND
     ELSE #255
    ENDIF
  >S			\ Save substring length
  1- OVER MIN
  ROT OVER + -ROT	\ Add substring start to start addr.
  -			\ Subtract it from length.
  S> MIN		\ Take length of substring.
  1			\ String marker.
  TOKEN ) CHK ;P

CMD MID$ DOMID$


: DOVAL		TOKEN ( CHK
		    SCAN-EXPR ?STR
		    $ptr -ROT $>TEMP
		    BL $ptr C!
		    TO parseptr	 BFNUMBER 0
		TOKEN ) CHK ;P

CMD VAL DOVAL


: DOSTR$	TOKEN ( CHK
		  SCAN-EXPR ?NUM
		  SKIP-SPACES iptr C@ TOKEN , =
		    IF NXT
		       SCAN-EXPR ?NUM F>S #32 UMIN
		       TOKEN , CHK
		       SCAN-EXPR ?NUM F>S 9 UMIN
		       DUP >S SET-PRECISION (F.)
		       S> 0= IF 1- ENDIF
		       ROT OVER - 0 MAX DUP $ptr >S $ptr SWAP BLANK +TO $ptr
		       $>TEMP S $ptr S> - 1
		  ELSE (F.) DUP -ROT $>TEMP $ptr OVER - SWAP 1
		 ENDIF
		TOKEN ) CHK ;P

CMD STR$ DOSTR$


: DOHPOS	?AT DROP 0 D>F 0 ;P

CMD HPOS DOHPOS


: DOVPOS	?AT NIP 0 D>F 0 ;P

CMD VPOS DOVPOS

: DORND		rseed #957 * #39 + DUP TO rseed
		U>D D>F	 0 1 D>F F/  0 ;P

CMD RND DORND


: DOINKEY$	EKEY?
		   IF EKEY single-chars + 1 1
		 ELSE 0 0 1
		ENDIF ;P

CMD INKEY$ DOINKEY$


: DOPEEK	TOKEN ( CHK
		    SCAN-EXPR ?NUM F>S C@ 0 D>F 0
		TOKEN ) CHK ;P

CMD PEEK DOPEEK


-- MODE(0) or MODE(1)

: DOMODE	TOKEN ( CHK
		    SCAN-EXPR ?NUM F>S IF GRAPHICS CENTER white SETCOLOR
				     ELSE TEXT
				    ENDIF
		TOKEN ) CHK ;P

CMD MODE DOMODE


-- INVERSE(0) or INVERSE(1)

: DOINVERSE	TOKEN ( CHK
		    SCAN-EXPR ?NUM F>S IF INVERSE ELSE -INVERSE ENDIF
		TOKEN ) CHK ;P

CMD INVERSE DOINVERSE


-- SCREEN$(row,col)

: DOSCREEN$	TOKEN ( CHK
		SCAN-EXPR ?NUM F>S
		TOKEN , CHK
		SCAN-EXPR ?NUM F>S
		TOKEN ) CHK
		SWAP @AT single-chars + 1 1 ;P

CMD SCREEN$ DOSCREEN$


: DOUCASE$	TOKEN ( CHK
		    SCAN-EXPR ?STR
		    $ptr OVER 2SWAP $>TEMP
		    2DUP
		    BOUNDS ?DO I C@ >UPC I C!
			  LOOP
		    1 ( string marker)
		TOKEN ) CHK ;P

CMD UCASE$ DOUCASE$


: DOPLOT	TOKEN ( CHK
		  SCAN-EXPR ?NUM F>S
		  TOKEN , CHK
		  SCAN-EXPR ?NUM F>S
		TOKEN ) CHK
		white SET-DOT ;P

CMD PLOT DOPLOT


: DODRAW	TOKEN ( CHK
		  SCAN-EXPR ?NUM F>S
		  TOKEN , CHK
		  SCAN-EXPR ?NUM F>S
		TOKEN ) CHK
		DRAWTO ;P

CMD DRAW DODRAW


: DOOPENIN	SKIP-SPACES SCAN-EXPR ?STR $OPEN-INPUT	[standard] ;P
		CMD OPENIN  DOOPENIN

: DOOPENOUT	SKIP-SPACES SCAN-EXPR ?STR $OPEN-OUTPUT [standard] ;P
		CMD OPENOUT DOOPENOUT

: DOCLOSEIN	CLOSE-INPUT  ;P		CMD CLOSEIN DOCLOSEIN
: DOCLOSEOUT	CLOSE-OUTPUT ;P		CMD CLOSEOUT DOCLOSEOUT

: DOEOF		GETCH EOF = S>F 0 ;	CMD EOF DOEOF

: DOGET		SKIP-SPACES iptr C@ TOKEN #1 = IF NXT SKIP-SPACES ENDIF
		SCAN-EXPR ?STR
		BOUNDS ?DO GETCH I C!	\ EOF ? String must be dimmed?
		      LOOP ;P

CMD GET DOGET


: DOPUT		SKIP-SPACES iptr C@ TOKEN #1 = IF NXT SKIP-SPACES ENDIF
		SCAN-EXPR ?STR
		BOUNDS ?DO I C@ PUTCH	\ String must be dimmed?
		      LOOP ;P

CMD PUT DOPUT


: DODELETE	SKIP-SPACES iptr C@
		1 = IF	1 +TO iptr  iptr 'F@' 1 FLOATS +TO iptr	 F>S TO minline
		  ELSE	CLEAR minline
		 ENDIF
		SKIP-SPACES iptr C@ TOKEN -
		  = IF NXT  SKIP-SPACES iptr C@
			1 = IF	1 +TO iptr  iptr 'F@' 1 FLOATS +TO iptr	 F>S TO maxline
			  ELSE -1 +TO maxline
			 ENDIF
		  ELSE minline 0= IF  -1  ELSE	minline	 ENDIF	TO maxline
		 ENDIF minline maxline > IF maxline
						minline TO maxline
					    TO minline
				      ENDIF
		maxline 1+ minline ?DO	I FINDLINE
					?DUP IF DELLINE	 ENDIF
				  LOOP ;P

CMD DELETE DODELETE


:ABOUT		CR ." Enter BASIC (BYE to stop)." ;

		CR .HELP
		DEPRIVE

				(* End of File *)