diff --git a/LICENSE.txt b/LICENSE.txt
new file mode 100644
--- /dev/null
+++ b/LICENSE.txt
@@ -0,0 +1,30 @@
+Copyright (c) 2009, Lyle Kopnicky
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+* Redistributions of source code must retain the above copyright
+ notice this list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the
+ distribution.
+
+* Neither the name of Lyle Kopnicky nor the names of his contributors
+ may be used to endorse or promote products derived from this
+ software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.txt b/README.txt
new file mode 100644
--- /dev/null
+++ b/README.txt
@@ -0,0 +1,45 @@
+To compile:
+
+runhaskell Setup.hs configure
+runhaskell Setup.hs build
+
+To run unit tests:
+
+runhaskell Setup.hs test
+
+To install:
+
+runhaskell Setup.hs install
+
+You can then run the resulting program as
+
+ vintbas [<.bas source file> ...]
+
+The monad transformer I created is CPST. Monad
+transformers are basically monad building-blocks. You
+start with the identity monad and stack monad
+transformers on top of it to build a combined monad.
+The ordering is very important. There are monad
+transformers in the Control.Monad.Trans library,
+so I used them. Unfortunately you can't stack any
+more monad transformers on top of CPST. It has to be on
+top, because of the type of the shift morphism. The
+standard ContT transformer is similar to my CPST, but
+defines callCC, not shift. Take a look at the type
+of callCC in my code. Notice every time you see a
+CPST, it is followed by an o. Notice that every
+other morphism in CPST has the same property, except
+shift. That is the key to why it's no longer stackable -
+monad transformers can take only two type parameters, not
+three. But I like shift and think it's neat that I
+can define callCC in terms of it and reset, but not
+vice-versa. So there. Plus, my shift and callCC are
+rank-3 polymorphic! Nobody else achieves that flexibility.
+
+Other things we could do:
+* Pre-check types
+* Pre-check labels, generate code in place of labels
+* Convert variable references to IORefs
+ Is it easiest to do these with staging?
+* Consider sending errors to stderr.
+* On syntax error, consider printing line with marked error.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,16 @@
+#!/usr/local/bin/runhaskell
+
+import Distribution.Simple
+import Distribution.PackageDescription (PackageDescription)
+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)
+import System.Cmd (system)
+import Distribution.Simple.LocalBuildInfo
+import System.Directory (removeFile)
+
+main = defaultMainWithHooks (simpleUserHooks {runTests = runAllTests})
+
+runAllTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()
+runAllTests a b pd lb = do
+ system "runhaskell run_tests.hs"
+ removeFile "test_driver.hs"
+ return ()
diff --git a/doc/Vintage_BASIC_Developer_Notes.html b/doc/Vintage_BASIC_Developer_Notes.html
new file mode 100644
--- /dev/null
+++ b/doc/Vintage_BASIC_Developer_Notes.html
@@ -0,0 +1,40 @@
+
+Vintage BASIC Developer Notes
+Vintage BASIC Developer Notes 1.0
© 2009, Lyle Kopnicky
I began Vintage BASIC as a class project at the Oregon Graduate
+Institute. My aim was to demonstrate advanced knowledge of monads in
+Haskell.
+It occurred to me that BASIC's dynamic control structures would be
+interesting to interpret using a custom monad. Soon, using a
+continuation-passing style monad as a basic, I was able to construct an
+advanced form of exception handler that was ideal for implementing the
+BASIC control structures in a new way.
What follows are notes on a few of the more notable aspects of the design.
Durable Traps
Most languages, like C,
+have lexical control structures. It can be determined statically where
+the boundaries of a loop lie. But BASIC's control flow statements are
+read and interpreted one by one at runtime. Traditionally, a GOSUB pushes a pointer to the next statement onto the stack, and RETURN pops that pointer off the stack to return to that position. Any RETURN in the program could be associated with any GOSUB, if the right GOTOs are sprinkled about.
Instead of using the traditional stack-based method of implementing GOSUB-RETURN, I implemented GOSUB as an exception handler, and RETURN raises an exception to be caught by the GOSUB. Similarly, FOR is an exception handler, and NEXT raises a special exception to be caught by the FOR.
+This is not too different from the stack-based approach, because a
+pointer stack has been replaced by a handler stack. However, the code
+is higher-level and more generalizable. It flows well in Haskell's
+monadic do notation.
Simple Java-like exceptions
+will not suffice. For one thing, they require a nested block of code
+from which exceptions will be caught. But BASIC has no lexical nesting.
+In principle, we want to catch exceptions that occur later in
+execution. In other words, we want to catch exceptions from the
+continuation of the handler. My new exception handlers can be used in
+either way: to catch exceptions from within an expression, or to trap exceptions from the handler's continuation. I refer to it as trapping because it works much like a trap statement in Bourne shell.
There
+are three actions an exception handler may take. In case an exception
+does not apply to the exception handler, it needs to pass on the exception to the next outer handler. When a NEXT exception occurs, the loop termination condition may or may not be met. If it is not met, control flow will continue following the handler (the interior of the loop). If it is met, control should resume with the statement following the NEXT.
There is one more behavior of a handler to consider: whether or not it remains in force. When a NEXT leads to another loop iteration, the handler should remain in force. When the FOR loop is complete, the handler should not remain in force. I refer to this feature as durability and say that in the first case, the handler endures, while in the second case it does not endure.
The exception handlers provided in Control.Monad.CPST.DurableTraps, catchC and trap, are used to catch or trap exceptions, respectively. Each one is passed, along with the exception, three functions called passOn, resume, and continue, corresponding to the three desired courses of action. Each of those functions takes a boolean parameter endure, which can be set to True to keep the handler in force or False to remove it from the handler stack.
Parsing
Although I originally hand-rolled a parser, I eventually moved to Parsec for better performance and error handling. I chose to implement the parsing in three layers. The line scanner layer recognizes BASIC line numbers and allows the lines to be sorted by line number without parsing the rest of the line. The tokenizer
+locates and tokenizes keywords in each line, without tokenizing
+variable names. I did this so that BASIC code could be written without
+spaces between the keywords and variables, as the Commodore 64 allowed.
+Finally, the parser does the rest of the work, building up statements and expressions.
I
+took care to make the syntax errors look reasonably old-fashioned.
+However, they do provide a bit more information than the old BASICs
+would have. Because Parsec provides it, they detail the error position
+and the found/expected tokens.
Unit Testing
Vintage
+BASIC is extensively covered with unit tests. These tests are written
+on top of the HUnit framework. Most of the tests are on parsing code or
+the interpreter. The interpreter tests are at more or less integration
+tests rather than unit tests. They test the interpretation of the BASIC
+language straight from the textual source. However they are still unit
+tests in the sense that they are focused on exercising the behavior of
+the interpreter proper.
The tests are arranged in a hierarchical directory structure parallel to the implementation: in the test directory rather than src. They are executed by a harness called run_tests.hs in the root directory. This custom-written script finds all of the modules named ending in _test, and the functions within those modules starting with test_. It builds a driver program that calls all the tests, and executes it.
The tests can be run by calling runhaskell run_tests.hs, or preferably via runhaskell Setup.hs test.
diff --git a/doc/Vintage_BASIC_Users_Guide.html b/doc/Vintage_BASIC_Users_Guide.html
new file mode 100644
--- /dev/null
+++ b/doc/Vintage_BASIC_Users_Guide.html
@@ -0,0 +1,752 @@
+
+
+Vintage BASIC User's Guide
+
+
+
+Vintage BASIC User's Guide 1.0
+© 2009, Lyle
+Kopnicky
+Congratulations on installing Vintage BASIC! You are now the
+proud owner of a copy of a versatile tool for BASIC development.
+Vintage BASIC is a language derived from the Microsoft's
+original Altair
+BASIC.
+It would feel right at home on a Commodore 64. The design tensions of
+Vintage BASIC are:
+
+- Run the majority of programs from BASIC
+Computer Games: Microcomputer Edition, by David H. Ahl. This
+book was a lot of fun and inspired a generation of programmers.
+- Stick fairly close to the behavior of Microsoft BASIC v2 as
+found on the Commodore 64.
+- Be informed by (but not always stick to) the ANSI Minimal
+BASIC standard (ANSI X.360-1978).
+- Relax constraints in the language where it is easy to do so
+without compromising compatibility.
+
+Vintage BASIC is written in Haskell.
+Haskell has a feature called monads, which aid in constructing custom
+control structures. The interpreter handles BASIC's dynamic
+control structures by using an advanced form of exception, rather than
+the traditional
+stack.
+
+Early BASICs used an interactive prompt for editing
+program text. Vintage BASIC allows you to use your own text editor.
+However, it still supports the line numbers of traditional BASIC, as
+targets for control flow.
+
+Table of Contents
+
+System
+Requirements and Installation
+Vintage BASIC requires minimal resources, and will run on any
+platform with available Haskell compiler. The recommended compiler is GHC. You can
+also download some pre-compiled binaries on the web site, vintage-basic.net.
+Installation of binary version
+For Windows, you can simply download vintbas.exe,
+and put it it somewhere in your path. For other systems, consult the download page.
+Installation from source
+You can download the source code tarball, vintage-basic-1.0.tar.gz, from
+either vintage-basic.net
+or Hackage.
+You should first unpack the tarball
+
+ runhaskell Setup.hs configure
+ runhaskell Setup.hs build
+The executable will be generated in dist/build/vintbas/vintbas
+on Mac/Linux, or dist\build\vintbas\vintbas.exe
+on Windows. You can then move this executable anywhere in your path to
+run it. Or, use
+ runhaskell Setup.hs install
+See the Cabal
+package installation instructions for more details.
+
+Running
+Vintage BASIC
+The interpreter consists of one command-line tool, vintbas (vintbas.exe
+on Windows). It can take any number of filename parameters, each one
+the name of a BASIC source file. By convention (but not fiat), those
+should end in .bas. So, if you've written
+BASIC code and saved it in miracle.bas, you'd
+run it by typing vintbas miracle.bas.
+BASIC
+Program Lines
+Each line in your BASIC source file should start with a BASIC
+line number (also called a label).
+These numbers are part of the text at the start of the
+line, and not just a count of lines from the start of the file. They
+are used as labels for GOTO, GOSUB,
+and THEN targets, as well as in RESTORE
+statements. Here is a sample BASIC program:
+10 INPUT"YES OR
+NO";A$
+20 IF A$ = "YES" THEN 50
+30 IF A$ = "NO" THEN 60
+40 PRINT"YOU MUST ENTER YES OR NO.":GOTO 10
+50 PRINT"GREAT!":END
+60 PRINT"WHY NOT?":END
+Barring any flow control changes, the lines are executed in
+order by line number, regardless of the sorting of the input file. If
+two lines in the input file have the same line number, the later one
+will take precedence (you will get a warning when lines are
+superseded). A space is not required following the line number, but it
+aids in readability.
+Control flow will end when your program reaches the end of the
+lines, when an END or STOP
+statement is encountered, or when an error occurs. Errors may occur
+during parsing or execution, and always being with an exclamation point
+(!).
+BASIC
+Syntax
+Each line of BASIC consists of a series of statements, separated by
+semicolons. Statements are executed in order, unless an error or
+control flow statement is encountered.
+BASIC keywords are not case sensitive. You may
+freely use
+lowercase, uppercase, or mix both. Examples will be shown in caps since
+that is traditional for the language. Literal strings in quotes are
+case sensitive. They will be printed in the case used in the source.
+Spaces are not required between keywords. This is a violation
+of the ANSI standard, but was implemented on some early microcomputers
+in order to save memory. It will aid in compatibility with running
+programs written for such computers. Spaces are encouraged because the
+code can be harder to read without them. For example, FORK=1TON
+appears to set the value of a variable FORK
+to a weight of 1 ton. In reality it begins a FOR
+loop with control variable K, ranging in
+value from 1 to N.
+Ignoring spaces means that keywords must be tokenized by the parser
+before the parsing phase. It also makes it difficult to use long
+variable names, which might accidentally contain keywords. For example,
+FACTOR contains the keyword TO.
+Experience shows that people can get used to reading code without
+spaces.
+BASIC
+Types
+Vintage BASIC has a simple type system. In expressions, all values are
+either floating-point or string. Variables can additionally hold
+integers, which are converted to/from floating-point to be used in
+expressions. Floating-point values are also used for boolean logic. The
+canonial true value is -1, and the canonical
+false value is 0. These are the values that
+will be generated by comparison operators. However, any nonzero value
+will be treated as true by the boolean operations.
+BASIC
+Expressions
+Expressions in BASIC, like in most languages, are used to
+compute a value. They can be used in many statements, such as LET,
+DIM, ON-GOTO, ON-GOSUB,
+IF-THEN, FOR, PRINT,
+and DEF FN. They consist of literal values
+and variable references, composed by operators and function calls.
+Let's look at each of these in turn.
+
+- literal
+- Literals include floating-point numbers and strings.
+Floating-point literals are of the form [+|-]999[.999][E[+|-]99]: a
+sign, a mantissa, and an exponent indicated by the letter E. The signs
+and exponent are optional. The decimal point is optional if you don't
+need to put any digits after it. Examples:
0,
+2, 5., 5.6,
+90000000, -.01, 1E-20.
+Precision depends upon your platform, but is generally IEEE bin32
+(single precision). There are no special IEEE values, like +Inf or NaN.
+String literals are enclosed in quotes, e.g. "HELLO".
+There are no escape sequences. To generate a quote character, append a CHR$(34).
+- varname
+- Variable names can include any number of letters followed
+by any number
+of digits, and a type indicator. However, only the first two letters
+and first digit are considered significant to distinguish variable
+names. Since computers historically did not have enough
+memory to handle long variable names, variable names were kept short.
+The ANSI Minimal BASIC standard, and some early BASICs, allowed only
+one letter and one digit in the variable name. In some later BASICs,
+the first two letters and the first digit of the variable name are
+considered significant. That is the choice made in Vintage BASIC. So,
+the variables
MILK123 and MINT145
+are considered the same.
+
+- Variables can store integers, floating-point
+numbers or strings. Integer variables are mainly there to save storage
+memory; in calculations they are converted to floats. String variable
+names are ended with a
$, and integer
+variables with a %, while floating-point
+variables have no type indicator. Variable names with the same
+significant letters and digits but different type indicators are
+distinct. Thus, you can store a string in A$,
+a floating-point value in A, and an integer
+value in A% without a conflict.
+- var
+- Variables can also be scalar or array. Scalar variables are
+indicated by an variable name alone. Array variables are accessed by
+following the variable name with parentheses enclosing a
+comma-separated list of expressions whose values are indices into the
+array. For example,
A(3) is the value from
+index 3 in the floating-point array named A,
+and FR$(2,3) is a string value from index 2
+(in the first dimension) and 3 (in the second dimension) in an array
+named FR$. Scalar and array variables are
+also distinct from each other, so it is possible to have a scalar
+variable A with value 3,
+so that A(A) would be A(3)
+and might contain some other value.
+FN varname(expr1,
+expr2,
+...)- Another sort of variable is a user-defined function.
+Defined using
DEF FN statements, they are
+accessed in expressions by preceding the function name with the FN
+keyword. Example: FN A(4) calls the
+floating-point user-defined function A with
+argument value 4.
+- builtin
(expr1,
+expr2,
+...)
+- Calls a builtin function. The names of the builtins are
+keywords, so they cannot be used in variable names. See the list of
+builtin functions below.
+(expr)- A parenthesized expression has the same value of
+expression. Parentheses can be used to override operator precedence.
+-
+expr- Negates a floating-point expression.
++ expr- No effect. This is included for parity with the negation
+operator.
+- expr1
+
^ expr2
+- Exponentiation. Raises the value of the first expression to
+the power of the value of the second expression.
+- expr1
+
* expr2
+- Multiplication. Multiplies the value of the first
+expression by the value of the second expression.
+- expr1
+
/ expr2
+- Division. Divides the value of the first expression by the
+value of the second expression. Division by zero is an error.
+- expr1
+
+ expr2
+- Addition. Adds the value of the first expression to the
+value of the second expression.
+
+- expr1
+
- expr2
+- Subtraction. Subtracts the value of the second expression
+from the value of the first expression.
+- expr1
+
= expr2
+- Equality test. Evaluates to
0
+if the two strings or numbers are equal, -1
+if they differ.
+- expr1
+
<> expr2
+- Inequality test. Evaluates to
-1
+if the two strings or numbers are equal, 0 if
+they differ.
+- expr1
+
< expr2
+- Less than. Evaluates to
-1 if the
+first string or number is less than the second, 0
+otherwise. (Strings are compared alphabetically.)
+- expr1
+
<= expr2
+- Less than or equal. Evaluates to
-1 if
+the first string or number is less than or equal to the second, 0
+otherwise. (Strings are compared alphabetically.)
+- expr1
+
> expr2
+- Greater than. Evaluates to
-1 if
+the first string or number is less than the second, 0
+otherwise. (Strings are compared alphabetically.)
+- expr1
>=
+expr2
+- Greater than or equal. Evaluates to
-1
+if the first string or number is less than or equal to the second, 0
+otherwise. (Strings are compared alphabetically.)
+NOT expr- Negates a boolean expression. Specifically, nonzero values
+become
0 and 0
+becomes -1.
+- expr1
+
AND expr2
+- Logical conjunction. If neither expression evaluates to
0,
+then the result is the value of expr1.
+Otherwise, the result is 0.
+- expr1
+
OR expr2
+- Logical disjunction. If expr1 evaluates to
+a nonzero value, that value is the result. Otherwise, the value of expr2 is the result.
+
+Operator
+Precedence and Associativity
+Operators are listed in precedence groups, from highest to lowest.
+
+
+
+| Operators |
+Associativity |
+
+
+unary -, unary + |
+N/A |
+
+
+^ |
+right |
+
+
+*, / |
+left |
+
+
++, - |
+left |
+
+
+=, <>,
+<, <=,
+>, >= |
+left |
+
+
+NOT |
+N/A |
+
+
+AND |
+left |
+
+
+OR |
+left |
+
+
+
+
+Builtin
+Functions
+The builtin functions each take a particular number of arguments of
+particular types. Passing the wrong number of arguments or types will
+result in a runtime error. Each argument can be an expression. The
+expressions are evaluated before being passed to the builtin function.
+
+ABS(float)- Returns the absolute value of an expression. (I.e., its
+negation if it is negative.)
+ASC(string)- Returns the ASCII value of the first character of the
+string.
+ATN(float)- Returns the arctangent of the value. The range is from -pi/2 to pi/2.
+CHR$(float)- Returns a single-character string with the specified ASCII
+value.
+COS(float)- Returns the cosine of the value.
+EXP(float)- Returns the transcendental number e raised to the
+power of the value.
+INT(float)- Rounds the number down to the next lower integer.
+LEFT$(string,
+float)- Returns a prefix of the string, with the number of
+characters specified by the second argument. Negative numbers are an
+error, while numbers too large will result in the whole string being
+returned.
+LEN(string)- Returns the length of the string.
+LOG(float)- Returns the logarithm, to base e, of the number.
+Argument must be positive.
+MID$(string,
+float)MID$(string,
+float,
+float)- In its first form, returns a substring starting from the
+specified index (1-based), through the end of the string. In the second
+form, returns a substring starting an index specified by the second
+argument, with the number of characters specified by the third
+argument. Indexes less than one or string lengths less than zero will
+result in a runtime error. Any attempt to extract characters beyond the
+length of the string will be cut off at the end of the string with no
+error.
+RIGHT$(string,
+float)- Returns a suffix of the string, with the number of
+characters specified by the second argument. Negative numbers are an
+error, while numbers too large will result in the whole string being
+returned.
+RND(float)- Psuedorandom number generator. The behavior is different
+depending on the value passed. If the value is positive, the result
+will be a new random value between 0 and 1 (including 0 but not 1). If
+the value is zero, the result will be a repeat of the last random
+number generated. If the value is negative, it will be rounded down to
+the nearest integer and used to reseed the random number generator.
+Pseudorandom sequences can be repeated by reseeding with the same
+number.
+SGN(float)- Sign. Returns -1 if the value is negative, 0 if it is zero,
+or 1 if it is positive.
+SIN(float)- Returns the sine of the specified value.
+SPC(float)- Returns a string containing the specified number of spaces.
+This is useful for formatting text.
+SQR(float)- Returns the square root of the value. Argument must be
+non-negative.
+STR(float)- Returns a string representation of the floating-point
+value, as it would be printed by
PRINT, but
+without the trailing space.
+TAB(float)- In most BASICs this is a special command available only in
PRINT
+statements, but in Vintage BASIC, it is just another builtin function.
+Vintage BASIC keeps track of the output column as text is printed. The TAB
+function generates a string with the number of spaces required
+to advance the cursor to the column number specified by the
+argument. Column numbers start with zero, which is consistent with
+Microsoft BASIC but not the ANSI standard, which starts with one
+instead. If the cursor is already past the desired column, the result
+string will be empty. This behavior is consistent with
+Microsoft BASIC but not the ANSI standard, which specifies that the
+cursor should move to a new line before tabbing to the specified column.
+TAN(float)- Returns the tangent of the value.
+VAL(string)- Attempts to read the string as a floating-point number. If
+it fails, the result is zero.
+
+BASIC
+Statements
+
+DATA literal1,
+literal2,
+...- Has no effect when executed, but supplies data for the
READ
+statement. Each value can be a string or floating-point literal (not an
+expression). Whitespace is ignored around values. Double quotes can be
+placed around a string to escape whitespace and commas between the
+quotes. DATA statements can occur on
+the same line as other statements, but, due to its special parsing
+rules, it must be the last statement on the line. The line on which the
+DATA statement occurs can be used as the
+target of a RESTORE statement. Example: DATA
+January, 31, "Martian History Month".
+DEF FN varname(arg1,
+arg2,
+...) = expr- Defines a user-defined function. The arguments are
+variable names that may be used in the expression.
+While the standard allows only for numeric functions of a single
+floating-point variable, Vintage BASIC permits string, integer or
+floating-point functions ofany number and type of arguments. Example:
DEF
+FN F(X) = X^2 + 3*X - 4. The argument variables shadow
+the original variables; that is, the value of the original variable
+with the same name will be restored after the function is evaluated.
+Like scalar variables but unlike arrays, user-defined functions may be
+repeatedly redefined. Warning: Recursive functions are definable, but
+will always result in an infinite loop.
+DIM varname(bound1, bound2, ...)- Dimensions an array. That is, specifies the number of
+dimensions and upper index bounds for an array. The lower bound is
+always zero. Unlike most BASICs, the boundaries are not limited to
+literal values; they can be any expression. Attempting to re-dimension
+an array will produce an error. Arrays can be referenced without
+dimensioning; in that case they are automatically created as
+one-dimenional arrays with an upper bound of 10. Example:
DIM
+RX$(20, 5) creates a two-dimensional, 20x5 array of
+strings.
+END- Terminates execution with no error condition. This
+statement is not required at the end of a program because control flow
+will end automatically there.
+FOR varname = start TO
+end [STEP
+increment]- Marks the start of a
FOR-NEXT
+loop, and its termination conditions. The control variable must be a
+floating-point variable. It is initialized to the value of the start expression.
+Each time a NEXT is encountered, the control
+variable is incremented by one, or by increment if the
+optional STEP clause is specified. If the
+value of the control variable has not exceeded the value
+of the end
+expression, control will continue with the statement following the FOR.
+But if the value of the control value exceeds end (greater than
+end if increment
+is positive, less than end if increment
+is negative), control will pass to the statement following the NEXT.
+The expressions start,
+end,
+and increment
+are evaluated only once at the start of the loop. The termination
+condition is not evaluated before entering the loop, as it is not
+always possible to determine where the corresponding NEXT
+might be, should the loop meet the termination condition. (This
+contradicts the ANSI standard, but the ANSI standard is unenforceable.)
+Example: FOR I = 1 TO 20 STEP 2: PRINT I, I*2: NEXT I.
+GOSUB label- Transfers control to the line numbered label. Upon
+encountering a
RETURN statement, control will
+return to the statement following the GOSUB.
+This is the cornerstone of structured programming in BASIC. Note: GO
+and SUB are separate keywords and may be
+separated by space.
+GOTO label- Transfers control to the line numbered label. Note:
GO
+and TO are separate keywords and may be
+separated by space.
+IF expr THEN
+statement1:
+statement2:
+...
+IF expr
+THEN label- Evaluates the truth of the supplied expression. If it is
+true, it executes the statements following it on the line. If it is
+false, control skips to the following line. The form with a label is a
+shorthand for
IF expr THEN
+GOTO label.
+Expressions are expected to have floating-point values. They are
+considered false if zero and true otherwise. Note: if statements follow
+the label
+form on the same line, they are ignored. Example: IF
+A>0 THEN Y=Y+3:GOTO 80.
+INPUT [prompt;]
+var1,
+var2,
+...- Reads input from an interactive user prompt. The optional
+prompt string is followed by a question mark and a space. The
+user may then enter a series of values separated by commas. The format
+is the same as in the
DATA statement, so
+quotes can be used to escape spaces or commas. Value types entered must
+match the variable types, or an error will be generated and the user
+will be re-prompted. The user will also be re-prompted (with a double
+question mark) if the user enters insufficient values to fill the
+variables. The variables may be scalar or (indexed) array variables.
+Examples: INPUT "NAME AND AGE";NA$(I), AG(I).
+LET var = expr- Evaluates the expression and assigns the value to the
+variable. The
LET keyword is optional.
+NEXT [var]- Returns control to a
FOR
+statement to determine whether the loop should be repeated. If the
+termination condition has not been met, control will proceed with the
+line following the FOR statement. If the
+termination condition has been met, control will proceed with the
+statement following the NEXT. How does the
+interpreter determine which FOR goes with the
+NEXT? It is determined dynamically. If the
+NEXT has no variable, then it is the most
+recently encountered non-terminated FOR. If
+the NEXT indicates a variable, then it is the
+most recently encountered non-terminated FOR
+with that control variable. Usually, it is simple to glance at code and
+see which pairs of FOR and NEXT
+statements go together. But due to the dynamic nature of the connection
+between them, it is possible to write NEXT
+statements that are sometimes connected with one FOR,
+sometimes another. For an example, see FOR.
+ON expr GOSUB
+label1, label2,
+...- Like
GOSUB, but makes a decision
+about the target line based on the result of evaluating an expression.
+The value of expr
+is rounded down to the nearest integer, and is used as an index into
+the list of labels, starting with 1. If the index is less than 1 or
+greater than the number of labels, control falls through to the next
+statement (as in Microsoft BASIC but in violation of the ANSI standard,
+which prescribes a runtime error).
+ON expr GOTO
+label1, label2,
+...- Like
GOTO, but makes a decision
+about the target line based on the result of evaluating an expression.
+The value of expr
+is rounded down to the nearest integer, and is used as an index into
+the list of labels, starting with 1. If the index is less than 1 or
+greater than the number of labels, control falls through to the next
+statement (as in Microsoft BASIC but in violation of the ANSI standard,
+which prescribes a runtime error).
+PRINT expr1 [;|,]
+expr2 [;|,]- Outputs text to the user. Multiple expressions can be
+separated by semicolons or commas. Semicolons leave no space between
+printed expressions. A comma is used to align text neatly in columns;
+it forces the next output column to be the start of the next print
+zone. Print zones are always 14 characters wide. A newline will be
+automatically printed at the end of the line, unless the
PRINT
+statement ends in a semicolon or comma. Floating-point values are
+automatically
+padded with one trailing space, and positive values are also padded
+with a leading space, so that they take up the same amount of space as
+negative numbers. Example: PRINT "TURN";TU, "YOU
+HAVE";LI;"LIVES LEFT".
+RANDOMIZE- Re-seeds the random number generator used for the
RND
+function, based on the number of seconds that have elapsed since
+midnight, local time.
+READ var1,
+var2,
+...- Reads data from
DATA statements
+into variables. A pointer is maintained into the DATA
+values, which could be anywhere within the program. Values are read in
+order into the variables, and the pointer is advanced. A runtime error
+occurs if there are not enough DATA values to
+fill the variables. The DATA pointer can be
+reset using a RESTORE statement. Example: READ
+A$, B.
+REM text- A comment (remark). All characters through the end of the
+line are considered to be part of the comment. Example:
REM
+BRIDGE BY J. Q. PROGRAMMER.
+RESTORE [label]- Adjusts the
DATA value pointer.
+Without a line number, the pointer is reset to the first DATA
+statement of the program. With a line number, the
+pointer is moved to the first DATA statement
+on or following that line.
+RETURN- Returns control to the statement following the most
+recently executed
GOSUB to which control has
+not already been RETURNed. GOSUB-RETURN
+pairs can be nested to any depth. If there is no such GOSUB,
+a runtime error occurs. As with FOR-NEXT, association of a RETURN
+with a GOSUB is dynamic; it cannot be
+statically determined in all cases.
+STOPEND
+statement could only appear at the end of the program. The STOP
+statement was designed to send control to that solitary END
+statement. Vintage BASIC imitates this behavior by treating the STOP
+statement as an END. This is unlike Microsoft
+version of BASIC, in which STOP is used to
+terminate the program without clearing variables, so that they can be
+inspected for debugging purpose, and the CONT
+statement can resume control where it left off. That wouldn't be very
+useful in Vintage BASIC, since it does not have a read-eval-print loop.
+Error
+Messages
+
+!BAD GOSUB TARGET label1
+in line label2- There is no line number corresponding to the target
+specified for the
GOSUB.
+!BAD GOTO TARGET label1
+in line label2- There is no line number corresponding to the target
+specified for the
GOTO.
+!BAD RESTORE TARGET label1
+in line label2- There is no line number corresponding to the target
+specified for the
RESTORE.
+!BREAK IN LINE label- A
STOP statement was encountered.
+!DIVISION BY ZERO IN LINE label- An attempt was made to divide by zero.
+!END OF INPUT IN LINE label- An attempt to
INPUT characters
+failed because the end of the standard input stream was reached.
+!INVALID ARGUMENT IN LINE label- The argument supplied to a builtin function was outside of
+the allowed range.
+!LINE NUMBERING ERROR IN RAW LINE nn- The line scanner could not properly read line numbers, or
+the file did not end in a newline.
+!MISMATCHED ARRAY DIMENSIONS IN LINE label- The
+number of indices used in an array reference does not match the number
+of bounds supplied in the DIM statement (1 if it was not dimensioned).
+!NEGATIVE ARRAY DIM IN LINE label- A negative value was supplied as an array index, or bound
+in a
DIM statement.
+!NEXT WITHOUT FOR ERROR IN LINE label- A
NEXT statement was encountered,
+but a matching FOR statement could not be
+found. Either a FOR statement was never
+encountered, or all FOR statements have
+reached their termination conditions.
+!NEXT WITHOUT FOR ERROR (VAR X) IN
+LINE label- A
NEXT statement was encountered,
+but a matching FOR statement could not be
+found. Either a FOR statement with that
+control variable was never encountered, or all FOR
+statements with that control variable have reached their termination
+conditions.
+
+!OUT OF ARRAY BOUNDS IN LINE label- A supplied array index exceeded the bound for that
+dimension.
+!OUT OF DATA IN LINE label- A
READ statement in this line
+tried to read data, but the DATA pointer has
+already reached the end of data strings in the program. You may have
+too few DATA statements, or a bad loop
+termination condition that causes too many READs.
+!REDIM'D ARRAY IN LINE label- A
DIM statement was encountered,
+but the array has already been dimensioned, either explicitly (through
+anorther DIM statement), or automatically
+(through reference to the array).
+!RETURN WITHOUT GOSUB ERROR IN LINE label- A
RETURN statement was
+encountered, but a matching GOSUB statement
+could not be found. Either a GOSUB statement
+was never encountered, or all GOSUB
+statements have already been RETURNed to.
+!SYNTAX ERROR IN LINE label- The program did not meet valid syntax
+requirements. The error may contain more details as to what
+symbols were found or expected.
+!TYPE MISMATCH IN LINE label- The
+type of an expression was not the type expected by the surrounding
+context, whether it be an operator, builtin function, user-defined
+function, array, or statement that requires an expression. In a
READ
+statement, the type of the variable did not match the value read.
+!UNDEFINED FUNCTION X IN
+LINE label- The user-defined function was called via
FN
+but has never been defined by DEF FN.
+!WRONG NUMBER OF ARGUMENTS IN LINE label- The wrong number of arguments were passed to the builtin or
+user-defined function.
+
+
diff --git a/examples/diamond.bas b/examples/diamond.bas
new file mode 100644
--- /dev/null
+++ b/examples/diamond.bas
@@ -0,0 +1,12 @@
+10 LINES=17
+20 FORI=1TOLINES/2+1
+30 FORJ=1TO(LINES+1)/2-I+1:PRINT" ";:NEXT
+40 FORJ=1TOI*2-1:PRINT"*";:NEXT
+50 PRINT
+60 NEXTI
+70 FORI=1TOLIVES/2:REM note misspelled variable is the same
+75 REM because variables are unique to only two characters
+80 FORJ=1TOI+1:PRINT" ";:NEXT
+90 FORJ=1TO((LINES+1)/2-I)*2-1:PRINT"*";:NEXT
+100 PRINT
+110 NEXTI
diff --git a/examples/math.bas b/examples/math.bas
new file mode 100644
--- /dev/null
+++ b/examples/math.bas
@@ -0,0 +1,10 @@
+10 INPUT"ENTER A NUMBER";N
+20 ?"ABS(N)=";ABS(N)
+25 ?"ATN(N)=";ATN(N)
+30 ?"COS(N)=";COS(N)
+40 ?"EXP(N)=";EXP(N)
+50 ?"INT(N)=";INT(N)
+60 ?"LOG(N)=";LOG(N)
+70 ?"SGN(N)=";SGN(N)
+80 ?"SQR(N)=";SQR(N)
+90 ?"TAN(N)=";TAN(N)
diff --git a/examples/name.bas b/examples/name.bas
new file mode 100644
--- /dev/null
+++ b/examples/name.bas
@@ -0,0 +1,5 @@
+10 INPUT"WHAT IS YOUR NAME";NAME$
+20 INPUT"ENTER A NUMBER";N
+30 FORI=1TON
+40 ?"HELLO, ";NAME$;"!"
+50 NEXT
diff --git a/examples/stars.bas b/examples/stars.bas
new file mode 100644
--- /dev/null
+++ b/examples/stars.bas
@@ -0,0 +1,14 @@
+10 INPUT "What is your name"; U$
+20 PRINT "Hello "; U$
+30 INPUT "How many stars do you want"; N
+40 S$ = ""
+50 FOR I = 1 TO N
+60 S$ = S$ + "*"
+70 NEXT I
+80 PRINT S$
+90 INPUT "Do you want more stars"; A$
+100 IF LEN(A$) = 0 THEN 90
+110 A$ = LEFT$(A$, 1)
+120 IF A$ = "Y" OR A$ = "y" THEN 30
+130 PRINT "Goodbye ";U$
+140 END
diff --git a/examples/strings.bas b/examples/strings.bas
new file mode 100644
--- /dev/null
+++ b/examples/strings.bas
@@ -0,0 +1,12 @@
+10 INPUT"ENTER A STRING";A$
+20 INPUT"ENTER A NUMBER";N
+30 ?"ASC(A$)=";ASC(A$)
+40 ?"CHR$(N)=";CHR$(N)
+50 ?"LEFT$(A$,N)=";LEFT$(A$,N)
+60 ?"MID$(A$,N)=";MID$(A$,N)
+70 ?"MID$(A$,N,3)=";MID$(A$,N,3)
+80 ?"RIGHT$(A$,N)=";RIGHT$(A$,N)
+90 ?"LEN(A$)=";LEN(A$)
+100 ?"VAL(A$)=";VAL(A$)
+110 ?"STR$(N)=";STR$(N)
+120 ?"SPC(N)='";SPC(N);"'"
diff --git a/run_tests.hs b/run_tests.hs
new file mode 100644
--- /dev/null
+++ b/run_tests.hs
@@ -0,0 +1,81 @@
+#!/usr/local/bin/runhaskell
+
+import Data.Array ((!))
+import Data.List (intersperse)
+import Data.Maybe (catMaybes)
+import System.Cmd (system)
+import System.Directory (doesDirectoryExist,getCurrentDirectory,getDirectoryContents)
+import System.FilePath (())
+import System.Environment (getArgs)
+import Text.Regex.Base
+import Text.Regex.Posix
+
+testFilePat = makeRegex "^.*_test.hs$" :: Regex
+testFuncPat = makeRegex "^ *(test_[A-Za-z0-9_']*) *=" :: Regex
+testModuleNamePat = makeRegex "^ *module *([A-Za-z0-9_'.]*)" :: Regex
+
+main = do
+ args <- getArgs
+ testModulePaths <- if null args then findModulePaths else return args
+ putStrLn "Running tests in files:"
+ sequence_ [putStrLn (" " ++ testModulePath) | testModulePath <- testModulePaths]
+ putStrLn ""
+ putStrLn "Tests found:"
+ modulesWithTests <-
+ sequence [do moduleCode <- readFile testModulePath
+ let testModule = findModuleName moduleCode
+ putStrLn (" " ++ testModule)
+ let tests = findTests moduleCode
+ sequence_ [putStrLn (" " ++ test) | test <- tests]
+ return (testModule, findTests moduleCode)
+ | testModulePath <- testModulePaths]
+ let testCode = genTestDriver modulesWithTests
+ writeFile "test_driver.hs" testCode
+ system ("runhaskell -itest -isrc test_driver.hs")
+
+findFilesInSubdirs :: FilePath -> IO [String]
+findFilesInSubdirs dir = do
+ files <- getDirectoryContents dir
+ let paths = [dir file | file <- filter (`notElem` [".", ".."]) files]
+ paths' <- sequence [do { t <- doesDirectoryExist path; if t then findFilesInSubdirs path else return [] } | path <- paths]
+ return $ concat (paths : paths')
+
+findModulePaths :: IO [String]
+findModulePaths = do
+ files <- findFilesInSubdirs "test"
+ return $ map head $ concat [match testFilePat file | file <- files]
+
+matchTextToSubstring :: MatchText String -> String
+matchTextToSubstring mt = fst (mt ! 1)
+
+findModuleName :: String -> String
+findModuleName str =
+ case matchOnceText testModuleNamePat str of
+ Nothing -> error "Unable to find module name in file"
+ (Just (_, mt, _)) -> matchTextToSubstring mt
+
+findTests :: String -> [String]
+findTests str = [matchTextToSubstring mt | mt <- matchAllText testFuncPat str]
+
+genTestDriver modulesWithTests =
+ "import System.Exit\n"
+ ++ "import Test.HUnit\n"
+ ++ concat [genImport testModule | (testModule,_) <- modulesWithTests]
+ ++ "\n"
+ ++ "main = do\n"
+ ++ " (Counts cases tried errors failures) <- runTestTT $\n"
+ ++ " TestList [\n"
+ ++ concat (intersperse ",\n"
+ [genTest testModule testFunc
+ | (testModule,testFuncs) <- modulesWithTests, testFunc <- testFuncs])
+ ++ "\n"
+ ++ " ]\n"
+ ++ " exitWith $ if errors > 0 || failures > 0\n"
+ ++ " then ExitFailure (errors+failures)\n"
+ ++ " else ExitSuccess\n"
+
+genImport testModule = "import qualified " ++ testModule ++ "\n"
+
+genTest testModule testFunc =
+ let qualifiedTest = testModule ++ "." ++ testFunc
+ in " TestLabel \"" ++ qualifiedTest ++ "\" " ++ qualifiedTest
diff --git a/src/Basic.hs b/src/Basic.hs
new file mode 100644
--- /dev/null
+++ b/src/Basic.hs
@@ -0,0 +1,14 @@
+import System.Environment(getArgs)
+import System.IO
+import Language.VintageBasic.Executer(executeFile)
+import Language.VintageBasic.BasicMonad(runProgram)
+import Control.Monad.CPST.DurableTraps(done)
+import IO.IOStream
+
+-- | Runs a list of BASIC programs specified on the command line.
+main :: IO ()
+main = do
+ args <- getArgs
+ runProgram (IOStream stdin) (IOStream stdout) $ do
+ sequence_ [executeFile fileName | fileName <- args]
+ done
diff --git a/src/Control/Monad/CPST.hs b/src/Control/Monad/CPST.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/CPST.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RankNTypes, UndecidableInstances #-}
+
+-- | A continuation-passing style monad transformer, providing partial continuations.
+-- Advantages of CPST over ContT include the definition of shift and reset in the
+-- monad, and the rank-3 polymorphism for flexible contexts. The disadvantage is that
+-- no other monad transformers can be composed on top of it, because it has too many
+-- parameters.
+
+module Control.Monad.CPST where
+
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Trans
+
+-- | Definition of the CPST (continuation-passing style) monad.
+newtype Monad m => CPST o m i =
+ CPST { unCPST :: (i -> m o) -> m o }
+
+instance (Monad m) => Functor (CPST o m) where
+ fmap f (CPST m') = CPST (\k -> m' (k . f))
+
+instance Monad m => Monad (CPST o m) where
+ return x = CPST (\k -> k x)
+ (CPST m') >>= f = CPST (\k -> m' (\x -> unCPST (f x) k))
+
+-- The basic monad utilities: runCPST, lift, liftIO
+
+-- | Runs code in the CPST monad.
+runCPST :: Monad m => CPST o m o -> m o
+runCPST (CPST m') = m' return
+
+instance MonadTrans (CPST o) where
+ lift m = CPST (\k -> do x <- m; k x)
+
+instance (MonadIO m) => MonadIO (CPST o m) where
+ liftIO = lift . liftIO
+
+-- The core morphisms of CPST: shift, reset --
+
+shift :: Monad m => ((forall a. i -> CPST a m o) -> CPST o m o) -> CPST o m i
+-- ^ Captures a partial continuation out to the nearest enclosing 'reset'.
+-- The rank-3 polymorphism permits the partial continuation to be used
+-- in multiple differing type contexts.
+shift f = CPST (\k -> runCPST (f (\x -> CPST (\k' -> k x >>= k'))))
+
+reset :: Monad m => CPST i m i -> CPST o m i
+reset m = CPST (\k -> do x <- runCPST m; k x)
+-- ALTERNATELY: reset m = CPST (runCPST m >>=)
+
+-- Other morphisms written in terms of shift & reset, without unwrapping
+-- the monad.
+
+abort :: Monad m => o -> CPST o m a
+abort x = shift (\_ -> return x)
+-- ALTERNATELY: abort x = CPST (\_ -> return x)
+
+callCC :: Monad m => ((forall a. i -> CPST o m a) -> CPST o m i) -> CPST o m i
+-- ^ Transforms a real continuation into a CPS-level continuation,
+-- passes it into f. The type is rank-3 polymorphic,
+-- which permits the same continuation to be used in different
+-- type contexts. This is OK since invoking the continuation
+-- disposes of the context.
+callCC f = shift (\k -> (f (\x -> k x >>= abort)) >>= k)
+-- ALTERNATELY: callCC f = CPST (\k -> unCPST (f (\x -> CPST (\_ -> k x))) k)
+
+instance MonadReader r m => MonadReader r (CPST o m) where
+ ask = lift ask
+ local f (CPST m') =
+ CPST (\k -> do r <- ask
+ local f (m' (\x -> local (const r) (k x))))
+
+instance MonadState s m => MonadState s (CPST o m) where
+ get = lift get
+ put s = lift $ put s
diff --git a/src/Control/Monad/CPST/DurableTraps.hs b/src/Control/Monad/CPST/DurableTraps.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/CPST/DurableTraps.hs
@@ -0,0 +1,139 @@
+{-# LANGUAGE FlexibleContexts, RankNTypes #-}
+
+-- | Support for advanced exception handling within the CPST monad.
+
+module Control.Monad.CPST.DurableTraps where
+
+import Control.Monad
+import Control.Monad.CPST
+import Control.Monad.CPST.ExceptionHandlers(capture,install,raise)
+
+class ResultType o where
+ okValue :: o
+
+-- | A continuation in the CPST monad, for code that may
+-- throw exceptions.
+type Cont o m i = i -> CPST (Excep o m i) m (Excep o m i)
+
+-- | The full-blown exception including not only an exception value,
+-- but a handler stack and continuation. Having all this allows
+-- an exception handler to manipulate the handler stack or resume
+-- using the exception's continuation.
+--
+-- [@o@] is the result type (e.g., OK, or an exception value)
+--
+-- [@i@] is the type to pass to the continuation (bound to the raise)
+--
+-- Both types must remain the same throughout your CPS computation.
+data Excep o m i =
+ Excep { exceptionValue :: o
+ , exceptionHandlerStack :: (Excep o m i -> CPST (Excep o m i) m (Excep o m i))
+ , exceptionContinuation :: (Cont o m i)
+ }
+
+-- | Packages the current continuation with the exception value,
+-- and an empty handler stack.
+raiseCC :: (Monad m, ResultType o) => o -> CPST (Excep o m i) m i
+raiseCC x = callCC (\k -> raise (Excep x return k))
+
+type ExceptionResumer o m = forall a. Bool -> CPST (Excep o m ()) m a
+
+type ExceptionHandler o m = Monad m => o -> ExceptionResumer o m -> ExceptionResumer o m
+ -> ExceptionResumer o m -> CPST (Excep o m ()) m (Excep o m ())
+
+-- | A flexible exception handling mechanism. It takes a function 'f' as a
+-- parameter, to which it passes three continuations: @passOn@, @resume@,
+-- and @continue@.
+--
+-- [@passOn@] pass control of the exception on up the handler chain (re-raise)
+--
+-- [@resume@] return to where the exception was raised (the exception's continuation)
+--
+-- [@continue@] continue with the code following the 'trap' statement
+-- (the handler's continuation)
+--
+-- Each of these continuations is parametrized by a boolean value:
+--
+-- [@endure = True@] keep this handler in force
+--
+-- [@endure = False@] disable this handler (remove it from the chain)
+
+trap :: Monad m
+ => ExceptionHandler o m -- ^ exception handler
+ -> CPST (Excep o m ()) m ()
+
+-- Local variables:
+--
+-- [@h hk@] the full handler with all logic
+--
+-- [@xv @] exception value
+--
+-- [@hk @] handler's continuation
+--
+-- [@hc @] handler chain
+--
+-- [@xk @] exception's continuation
+
+trap f = callCC (\hk -> install (h hk))
+ where h hk (Excep xv hc xk) =
+ let hc' exc' = capture (h hk) (hc exc')
+ xk' v = capture (h hk) (xk v) >>= raise
+ passOn endure =
+ if endure
+ then raise (Excep xv hc' xk')
+ else raise (Excep xv hc xk')
+ resume endure =
+ if endure
+ then xk' () -- might want other than (),
+ else xk () >>= raise -- say, for implementing state
+ continue endure =
+ if endure
+ then install hc' >>= hk >>= raise
+ else install hc >>= hk >>= raise
+ in f xv passOn resume continue
+
+-- | The catching version of trap. It catches exceptions from
+-- an expression, instead of from its continuation.
+
+catchC :: Monad m
+ => ExceptionHandler o m -- ^ exception handler
+ -> CPST (Excep o m ()) m (Excep o m ()) -- ^ computation in which to catch exceptions
+ -> CPST (Excep o m ()) m (Excep o m ())
+
+catchC f m = callCC (\hk -> capture (h hk) m)
+ where h hk (Excep xv hc xk) =
+ let hc' exc' = capture (h hk) (hc exc')
+ xk' v = capture (h hk) (xk v) >>= hk >>= raise
+ passOn endure =
+ if endure
+ then raise (Excep xv hc' xk')
+ else raise (Excep xv hc xk')
+ resume endure =
+ if endure
+ then xk' () -- might want other than (),
+ else xk () >>= raise -- say, for implementing state
+ continue endure =
+ if endure
+ then install hc' >> hk (Excep xv hc' xk') >>= raise
+ else install hc >> hk (Excep xv hc xk') >>= raise
+ in f xv passOn resume continue
+
+-- | Like abort, ends in the middle of a program. Can be resumed.
+end :: (Monad m, ResultType o) => CPST (Excep o m i) m i
+end = raiseCC okValue
+
+-- | Can be added at the end of a @do@-sequence to make the return type
+-- match the ultimate return type. It returns OK with a continuation that
+-- regenerates itself.
+done :: (Monad m, ResultType o) => CPST (Excep o m i) m (Excep o m i)
+done = return (Excep okValue return (\_ -> done))
+
+-- | Raises an exception that can't be resumed, and can be used in any context.
+die :: (Monad m, ResultType o) => o -> CPST (Excep o m i) m a
+die x = raise (Excep x return (error "cannot resume from a die"))
+
+-- Note: getCC might seem like a nice idea, but it's untypable, since the continuation
+-- has to take itself as an argument. An incorrect attempt:
+--
+-- getcc :: CPST o m (Cont m o i)
+-- getcc = callCC (\k -> return k)
diff --git a/src/Control/Monad/CPST/ExceptionHandlers.hs b/src/Control/Monad/CPST/ExceptionHandlers.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/CPST/ExceptionHandlers.hs
@@ -0,0 +1,75 @@
+-- | Exception handlers for the CPST monad, both \'catching\' (within an expression)
+-- and \'trapping\' (from the handler's continuation).
+
+module Control.Monad.CPST.ExceptionHandlers where
+
+import Control.Monad
+import Control.Monad.CPST
+
+-- The inward (catching) exception handlers --
+
+-- | Captures an exception that occurs within the specified computation.
+-- Like @try-catch@ in Java, but without the filtering of exceptions.
+capture :: Monad m
+ => (o1 -> CPST o m i) -- ^ the exception handler
+ -> CPST o1 m o1 -- ^ the computation within which to capture exceptions
+ -> CPST o m i
+capture f m = reset m >>= f
+
+-- | Forces a computation to occur after another one, even if the first one is
+-- aborted. Like @try-finally@ in Java.
+tack :: Monad m
+ => CPST o m i -- ^ the computation to tack on (@finally@ clause)
+ -> CPST o1 m o1 -- ^ the computation to wrap (@try@ clause)
+ -> CPST o m i
+tack m = capture (\_ -> m)
+
+-- | Catches exceptions in a computation that satisfy a predicate, and applies
+-- a function to them. If the exception does not match the predicate, it
+-- rethrows the exception. This is like @try-catch@ in Java.
+handle :: Monad m
+ => (o -> Bool) -- ^ the condition for matching the exception
+ -> (o -> CPST o m o) -- ^ the exception handler
+ -> CPST o m o -- ^ the computation within which to catch exceptions
+ -> CPST o m o
+handle t f = capture (\x -> if t x then f x else abort x)
+
+-- The outward (trapping) exception handlers --
+
+-- | Captures an exception that occurs in the continuation of this statement.
+-- Like a @trap@ statement in Bourne shell or Windows PowerShell, but without
+-- discriminating over the exception type.
+captureAtEnd :: Monad m
+ => (o -> CPST o m o) -- ^ the exception handler
+ -> CPST o m ()
+captureAtEnd f = shift (\k -> reset (k ()) >>= f)
+-- ALTERNATELY: captureAtEnd f = CPST (\k -> do x <- k (); runCPST (f x))
+-- ALTERNATELY: captureAtEnd f = callCC (\k -> reset (k ()) >>= f >>= abort)
+
+-- | Forces a computation to occur at the end of execution. Like an @END@
+-- block in Perl or @atexit()@ in C.
+tackAtEnd :: Monad m
+ => CPST o m o -- ^ the computation to tack at the end of execution
+ -> CPST o m ()
+tackAtEnd m = captureAtEnd (\_ -> m)
+-- ALTERNATELY: tackAtEnd m = CPST (\k -> do k (); runCPST m)
+
+-- | Handles an exception that occurs in the continuation of this statement.
+-- Like a @trap@ statement in Bourne shell or Windows PowerShell.
+-- The exception is only caught if it matches a predicate. Otherwise, it is
+-- passed on to the next outer handler.
+handleAtEnd :: Monad m
+ => (o -> Bool) -- ^ the condition for matching the exception
+ -> (o -> CPST o m o) -- ^ the exception handler
+ -> CPST o m ()
+handleAtEnd t f = captureAtEnd (\x -> if t x then f x else return x)
+
+-- Some convenient aliases
+
+-- | An alias for 'abort'.
+raise :: Monad m => o -> CPST o m a
+raise = abort
+
+-- | An alias for 'captureAtEnd'.
+install :: Monad m => (o -> CPST o m o) -> CPST o m ()
+install = captureAtEnd
diff --git a/src/IO/IOStream.hs b/src/IO/IOStream.hs
new file mode 100644
--- /dev/null
+++ b/src/IO/IOStream.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE ExistentialQuantification, FlexibleInstances #-}
+
+-- | A class describing IO operations with instances for IO and strings.
+-- This is primarily for the purpose of unit testing.
+module IO.IOStream (IOStream(..),IOStream'(..)) where
+
+import Data.IORef
+import System.IO
+
+-- | The abstract base class describing methods for IOStreams.
+-- The purpose of each function is identical to the ones in
+-- System.IO.Handle starting with an 'h' instead of a 'v'.
+class IOStream' h where
+ vGetContents :: h -> IO String
+ vSetContents :: h -> String -> IO ()
+ vPutStr :: h -> String -> IO ()
+ vFlush :: h -> IO ()
+ vGetLine :: h -> IO String
+ vIsEOF :: h -> IO Bool
+
+-- | An instance of IOStream' for IO Handles.
+instance IOStream' Handle where
+ vGetContents = hGetContents
+ vSetContents h s = hSetFileSize h 0 >> hPutStr h s
+ vPutStr = hPutStr
+ vFlush = hFlush
+ vGetLine = hGetLine
+ vIsEOF = hIsEOF
+
+-- | An instance for IOStream' for references to Strings.
+instance IOStream' (IORef String) where
+ vGetContents h = readIORef h
+ vSetContents h s = writeIORef h s
+ vPutStr h s = modifyIORef h (\text -> text ++ s)
+ vFlush _ = return ()
+ vGetLine h = do
+ text <- readIORef h
+ let (s, text') = span (/= '\n') text
+ if not (null text') && head text' == '\n'
+ then do
+ writeIORef h (tail text')
+ return s
+ else do
+ writeIORef h ""
+ return text'
+ vIsEOF h = do
+ text <- readIORef h
+ return $ null text
+
+-- | A datatype wrapper for IOStream'.
+data IOStream = forall h. IOStream' h => IOStream h
+
+-- | IOStream is itself an instance of IOStream', which reduces the
+-- overhead of unwrapping them from the IOStream constructor.
+instance IOStream' IOStream where
+ vGetContents (IOStream h) = vGetContents h
+ vSetContents (IOStream h) = vSetContents h
+ vPutStr (IOStream h) = vPutStr h
+ vFlush (IOStream h) = vFlush h
+ vGetLine (IOStream h) = vGetLine h
+ vIsEOF (IOStream h) = vIsEOF h
diff --git a/src/Language/VintageBasic/BasicMonad.hs b/src/Language/VintageBasic/BasicMonad.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/BasicMonad.hs
@@ -0,0 +1,289 @@
+{-# LANGUAGE FlexibleContexts, Rank2Types #-}
+
+-- | This monad provides runtime support for variable assignment,
+-- user-defined functions, I/O, and a jump table.
+
+module Language.VintageBasic.BasicMonad where
+
+import Prelude hiding (lookup)
+import Control.Monad.CPST
+import Control.Monad.CPST.DurableTraps
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Trans
+import Data.HashTable
+import Data.IORef
+import Data.Array.IO
+import Data.Maybe
+import Data.Time
+import IO.IOStream
+import Language.VintageBasic.Printer(printVarName)
+import Language.VintageBasic.Result
+import Language.VintageBasic.Syntax
+import System.Random
+
+-- | Values in BASIC programs.
+data Val = FloatVal Float | IntVal Int | StringVal String
+ deriving (Eq,Show,Ord)
+
+instance Typeable Val where
+ typeOf (FloatVal _) = FloatType
+ typeOf (IntVal _) = IntType
+ typeOf (StringVal _) = StringType
+
+-- | The default variable value (before assignment) for each BASIC type.
+defVal :: ValType -> Val
+defVal FloatType = FloatVal 0
+defVal IntType = IntVal 0
+defVal StringType = StringVal ""
+
+-- | The store of BASIC variables.
+data BasicStore = BasicStore {
+ scalarTable :: HashTable VarName (IORef Val),
+ -- ^ scalar variable assignments
+ arrayTable :: HashTable VarName ([Int], IOArray Int Val),
+ -- ^ array variable values (@[Int]@ lists the bound of each dimension)
+ fnTable :: HashTable VarName (IORef ([Val] -> Code Val))
+ -- ^ user-defined function (@DEF FN@) definitions
+}
+
+-- | The default array bounds.
+defBounds :: [Int]
+defBounds = [11] -- one dimension, 0-10
+
+-- | The common way to convert Float to Int values in BASIC is to round down.
+floatToInt :: Float -> Int
+floatToInt = floor
+
+data BasicState = BasicState {
+ inputStream :: IOStream, -- ^ where @INPUT@ comes from
+ outputStream :: IOStream, -- ^ where @PRINT@ output goes
+ lineNumber :: Int, -- ^ for error reporting
+ outputColumn :: Int, -- ^ for the @TAB()@ function
+ prevRandomVal :: Float, -- ^ the previously generated random value
+ randomGen :: StdGen, -- ^ random number generator
+ dataStrings :: [String] -- ^ the strings extracted from all @DATA@ statements
+}
+
+type BasicRT = ReaderT BasicStore (StateT BasicState IO)
+type Basic o = CPST o BasicRT
+type BasicCont o i = Cont o BasicRT i
+type BasicExcep o i = Excep o BasicRT i
+type Code a = Basic (BasicExcep Result ()) a
+type Program = Code (BasicExcep Result ())
+type BasicExceptionHandler = ExceptionHandler Result BasicRT
+
+-- | An exception handler used to print error messages at the outermost
+-- level of execution.
+errorDumper :: BasicExceptionHandler
+errorDumper x _ _ continue = do
+ case x of
+ Pass -> return ()
+ _ -> printString $ (show x ++ "\n")
+ continue False
+
+-- | Runs an interpreted BASIC program using the supplied input and output streams.
+runProgram
+ :: IOStream -- ^ input stream
+ -> IOStream -- ^ output stream
+ -> Program -- ^ the BASIC program, in lazy interpreted form
+ -> IO ()
+runProgram inputHandle outputHandle prog = do
+ vFlush outputHandle
+ st <- new (==) (hashString . printVarName)
+ at <- new (==) (hashString . printVarName)
+ ft <- new (==) (hashString . printVarName)
+ let store = BasicStore st at ft
+ let state = (BasicState inputHandle outputHandle 0 0 0 (mkStdGen 0) [])
+ runStateT (runReaderT (runCPST (catchC errorDumper prog)) store) state
+ return ()
+
+-- | Raises a runtime error if the assertion is False.
+assert :: Bool -> RuntimeError -> Code ()
+assert cond err = if cond then return () else raiseRuntimeError err
+
+raiseRuntimeException :: RuntimeException -> Code ()
+raiseRuntimeException rte = do
+ state <- get
+ raiseCC (LabeledRuntimeException (lineNumber state) rte)
+ return ()
+
+raiseRuntimeError :: RuntimeError -> Code ()
+raiseRuntimeError err = raiseRuntimeException (RuntimeError err)
+
+extractFloatOrFail :: RuntimeError -> Val -> Code Float
+extractFloatOrFail _ (FloatVal fv) = return fv
+extractFloatOrFail err _ = raiseRuntimeError err >> return 0
+
+-- | Get the value of a scalar variable.
+getScalarVar :: VarName -> Basic o Val
+getScalarVar vn = do
+ store <- ask
+ liftIO $ do
+ maybeVarRef <- lookup (scalarTable store) vn
+ case maybeVarRef of
+ Nothing -> return (defVal (typeOf vn))
+ (Just varRef) -> readIORef varRef
+
+-- | Set the value of a scalar variable.
+setScalarVar :: VarName -> Val -> Basic o ()
+setScalarVar vn val = do
+ store <- ask
+ liftIO $ do
+ maybeVarRef <- lookup (scalarTable store) vn
+ case maybeVarRef of
+ Nothing -> do
+ ref <- newIORef val
+ insert (scalarTable store) vn ref
+ (Just varRef) -> writeIORef varRef val
+
+-- | BASIC indices range from zero to an upper bound.
+-- We're storing 1+ that bound, to make computations easier.
+indicesAreWithinBounds :: [Int] -> [Int] -> Bool
+indicesAreWithinBounds bounds indices =
+ and $ (zipWith (>) bounds indices) ++ (map (>=0) indices)
+
+-- | Given the array's bounds and indices, compute the linear index
+-- into the storage array.
+arrIndex :: [Int] -> [Int] -> Int
+arrIndex bounds indices =
+ let scales = tail $ scanr (*) 1 bounds
+ in sum $ zipWith (*) scales indices
+
+-- | Create a new array in the store, with the specified name and bounds.
+dimArray :: VarName -> [Int] -> Code ([Int], (IOArray Int Val))
+dimArray vn bounds = do
+ store <- ask
+ maybeArray <- liftIO $ lookup (arrayTable store) vn
+ assert (isNothing maybeArray) ReDimensionedArrayError
+ arr <- liftIO $ newArray (0, product bounds - 1) (defVal (typeOf vn))
+ liftIO $ insert (arrayTable store) vn (bounds, arr)
+ return (bounds, arr)
+
+-- | Look up an array from the store. Indices are provided just to check
+-- validity.
+lookupArray :: VarName -> [Int] -> Code ([Int], (IOArray Int Val))
+lookupArray vn indices = do
+ store <- ask
+ maybeArray <- liftIO $ lookup (arrayTable store) vn
+ (bounds, arr) <- case maybeArray of
+ Nothing -> dimArray vn defBounds
+ (Just (bounds, arr)) -> return (bounds, arr)
+ assert (length bounds == length indices) MismatchedArrayDimensionsError
+ assert (indicesAreWithinBounds bounds indices) OutOfArrayBoundsError
+ return (bounds, arr)
+
+-- | Get a value from an array variable.
+getArrVar :: VarName -> [Int] -> Code Val
+getArrVar vn indices = do
+ (bounds, arr) <- lookupArray vn indices
+ liftIO $ readArray arr (arrIndex bounds indices)
+
+-- | Set a value in an array variable.
+setArrVar :: VarName -> [Int] -> Val -> Code ()
+setArrVar vn indices val = do
+ (bounds, arr) <- lookupArray vn indices
+ liftIO $ writeArray arr (arrIndex bounds indices) val
+
+-- | Retrieve the code for a user-defined function from the store.
+getFn :: VarName -> Code ([Val] -> Code Val)
+getFn vn = do
+ store <- ask
+ maybeVarRef <- liftIO $ lookup (fnTable store) vn
+ assert (isJust maybeVarRef) (UndefinedFunctionError vn)
+ liftIO $ readIORef (fromJust maybeVarRef)
+
+-- | Define a user-defined function in the store.
+setFn :: VarName -> ([Val] -> Code Val) -> Code ()
+setFn vn fn = do
+ store <- ask
+ liftIO $ do
+ maybeVarRef <- lookup (fnTable store) vn
+ case maybeVarRef of
+ Nothing -> do
+ ref <- newIORef fn
+ insert (fnTable store) vn ref
+ (Just varRef) -> writeIORef varRef fn
+
+-- | Set the current line number in the BASIC state.
+setLineNumber :: Int -> Basic o ()
+setLineNumber lineNum = modify (\state -> state { lineNumber = lineNum })
+
+-- | The width of print zones, used for commas in a @PRINT@ statement.
+zoneWidth :: Int
+zoneWidth = 14
+
+-- | Output a string, updating the current output column in the state.
+printString :: String -> Basic o ()
+printString s = do
+ state <- get
+ let startCol = outputColumn state
+ liftIO $ vPutStr (outputStream state) s >> vFlush (outputStream state)
+ put (state { outputColumn = endCol startCol s })
+
+-- | Given a starting column and a string, returns the ending column,
+-- were that string to be output.
+endCol :: Int -> String -> Int
+endCol startCol "" = startCol
+endCol _ ('\n' : s) = endCol 0 s
+endCol _ ('\r' : s) = endCol 0 s
+endCol startCol (_ : s) = endCol (startCol + 1) s
+
+-- | Retrieves the current output column from the state.
+getOutputColumn :: Code Int
+getOutputColumn = do
+ state <- get
+ return $ outputColumn state
+
+-- | Gets an input line, raising an exception if we are at EOF.
+getString :: Code String
+getString = do
+ state <- get
+ liftIO $ vFlush (outputStream state)
+ eof <- liftIO $ vIsEOF (inputStream state)
+ assert (not eof) EndOfInputError
+ liftIO $ vGetLine (inputStream state)
+
+-- | The number of seconds that have elapsed since midnight (local time).
+secondsSinceMidnight :: Code Int
+secondsSinceMidnight = do
+ zonedTime <- liftIO getZonedTime
+ return (floor $ toRational $ timeOfDayToTime $ localTimeOfDay $
+ zonedTimeToLocalTime zonedTime)
+
+-- | Seeds the BASIC random number generator using an integer.
+seedRandom :: Int -> Code ()
+seedRandom i = modify (\state -> state { randomGen = (mkStdGen i) })
+
+-- | Seeds the BAISC random number generator based on the number of
+-- seconds since midnight.
+seedRandomFromTime :: Code ()
+seedRandomFromTime = secondsSinceMidnight >>= seedRandom
+
+-- | Get the previously generated random number from the state.
+-- Used for @RND(0)@.
+getPrevRandom :: Code Float
+getPrevRandom = do
+ state <- get
+ return (prevRandomVal state)
+
+-- | Generate a new random number.
+getRandom :: Code Float
+getRandom = do
+ state <- get
+ let (rVal, rGen) = random (randomGen state)
+ put (state { prevRandomVal = rVal, randomGen = rGen })
+ return rVal
+
+-- | Set the list of @DATA@ statement strings in the store.
+setDataStrings :: [String] -> Code ()
+setDataStrings ds = modify (\store -> store { dataStrings = ds })
+
+-- | @READ@ the next @DATA@ value from the data strings.
+readData :: Code String
+readData = do
+ state <- get
+ let ds = dataStrings state
+ assert (not (null ds)) OutOfDataError
+ put (state { dataStrings = tail ds })
+ return (head ds)
diff --git a/src/Language/VintageBasic/Builtins.hs b/src/Language/VintageBasic/Builtins.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/Builtins.hs
@@ -0,0 +1,36 @@
+-- | A representation of BASIC's builtin functions.
+
+module Language.VintageBasic.Builtins where
+
+-- | An enumeration of BASIC's builtin functions.
+data Builtin =
+ AbsBI | AscBI | AtnBI | ChrBI | CosBI | ExpBI | IntBI | LeftBI | LenBI | LogBI | MidBI
+ | RightBI | RndBI | SgnBI | SinBI | SpcBI | StrBI | SqrBI | TabBI | TanBI | ValBI
+ deriving (Show,Eq)
+
+-- | An association list mapping BASIC builtins to their string representation.
+-- It is used forwards to print BASIC code, and backwards to parse BASIC code.
+builtinToStrAssoc :: [(Builtin, String)]
+builtinToStrAssoc = [
+ (AbsBI, "ABS" ),
+ (AscBI, "ASC" ),
+ (AtnBI, "ATN" ),
+ (ChrBI, "CHR$" ),
+ (CosBI, "COS" ),
+ (ExpBI, "EXP" ),
+ (IntBI, "INT" ),
+ (LeftBI, "LEFT$" ),
+ (LenBI, "LEN" ),
+ (LogBI, "LOG" ),
+ (MidBI, "MID$" ),
+ (RightBI, "RIGHT$"),
+ (RndBI, "RND" ),
+ (SgnBI, "SGN" ),
+ (SinBI, "SIN" ),
+ (SpcBI, "SPC" ),
+ (StrBI, "STR$" ),
+ (SqrBI, "SQR" ),
+ (TabBI, "TAB" ),
+ (TanBI, "TAN" ),
+ (ValBI, "VAL" )
+ ]
diff --git a/src/Language/VintageBasic/Executer.hs b/src/Language/VintageBasic/Executer.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/Executer.hs
@@ -0,0 +1,73 @@
+-- | The shell of the interpreter. It processes command-line parameters,
+-- and calls the line scanner, tokenizer, parser, and interpreter.
+
+module Language.VintageBasic.Executer where
+
+import Control.Monad.CPST.DurableTraps(die)
+import Control.Monad.State(get)
+import Control.Monad.Trans(liftIO)
+import Data.List(deleteFirstsBy,nubBy,sortBy)
+import Language.VintageBasic.Interpreter(interpLines)
+import Language.VintageBasic.LexCommon(Tagged(..))
+import Language.VintageBasic.LineScanner(RawLine,rawLinesP)
+import Language.VintageBasic.BasicMonad(BasicState(..),Code,printString,runProgram)
+import Language.VintageBasic.Parser(statementListP)
+import Language.VintageBasic.Result(Result(..))
+import Language.VintageBasic.Syntax(Line(..))
+import Language.VintageBasic.Tokenizer(TokenizedLine,taggedTokensP)
+import Text.ParserCombinators.Parsec(parse,setPosition,sourceLine)
+
+-- | Given a file path, loads and executes the BASIC code.
+executeFile :: FilePath -> Code ()
+executeFile fileName = do
+ text <- liftIO $ readFile fileName
+ execute fileName text
+
+-- | Executes BASIC code from a string. The file path is provided only for error reporting.
+execute :: FilePath -> String -> Code ()
+execute fileName text = do
+ rawLines <- scanLines fileName text
+ tokenizedLines <- sequence [tokenizeLine rawLine | rawLine <- rawLines]
+ parsedLines <- sequence [parseLine tokenizedLine | tokenizedLine <- tokenizedLines]
+ state <- get
+ liftIO $ runProgram (inputStream state) (outputStream state) $ interpLines parsedLines
+
+-- | Transforms the BASIC source into a series of 'RawLine's using the 'rawLinesP' LineScanner.
+scanLines :: String -> String -> Code [RawLine]
+scanLines fileName text =
+ case parse rawLinesP fileName text of
+ (Left parseError) -> die (ScanError parseError)
+ (Right rawLines) -> sortNubLines rawLines
+
+-- | Tokenizes a 'RawLine' into a 'TokenizedLine' using the 'taggedTokensP' Tokenizer.
+tokenizeLine :: RawLine -> Code TokenizedLine
+tokenizeLine (Tagged pos text) =
+ case parse (setPosition pos >> taggedTokensP) "" text of
+ (Left parseError) -> die (SyntaxError parseError)
+ (Right taggedTokens) -> return (Tagged pos taggedTokens)
+
+-- | Parses a 'TokenizedLine' to yield a 'Line', using the 'statementListP' Parser.
+parseLine :: TokenizedLine -> Code Line
+parseLine (Tagged pos taggedTokens) = do
+ case parse (setPosition pos >> statementListP) "" taggedTokens of
+ (Left parseError) -> die (SyntaxError parseError)
+ (Right statementList) -> return (Line (sourceLine pos) statementList)
+
+-- | Specifies an ordering for 'RawLine's so they can be sorted.
+rawLineOrdering :: RawLine -> RawLine -> Ordering
+rawLineOrdering (Tagged pos1 _) (Tagged pos2 _) = compare (sourceLine pos1) (sourceLine pos2)
+
+rawLinesEq :: RawLine -> RawLine -> Bool
+rawLinesEq l1 l2 = rawLineOrdering l1 l2 == EQ
+
+-- | This function reverses before nubbing so that later lines take precedence.
+sortNubLines :: [RawLine] -> Code [RawLine]
+sortNubLines lineList = do
+ let sortedLines = sortBy rawLineOrdering lineList
+ reversedSortedLines = reverse sortedLines
+ reversedNubbedLines = nubBy rawLinesEq reversedSortedLines
+ nubbedLines = reverse reversedNubbedLines
+ duplicateLines = deleteFirstsBy rawLinesEq lineList nubbedLines
+ sequence_ [printString ("!SUPERSEDING PREVIOUS LINE " ++ show (sourceLine pos) ++ "\n")
+ | (Tagged pos _) <- duplicateLines]
+ return nubbedLines
diff --git a/src/Language/VintageBasic/FloatParser.hs b/src/Language/VintageBasic/FloatParser.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/FloatParser.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
+-- | Code for parsing floats. Used both in parsing static code and at runtime
+-- (@INPUT@ and @DATA@ statements).
+
+module Language.VintageBasic.FloatParser(FloatParser(..)) where
+
+import Data.Char(isDigit)
+import Text.ParserCombinators.Parsec
+import Language.VintageBasic.LexCommon(Tagged,getTaggedVal)
+import Language.VintageBasic.Tokenizer(Token(..),tokenP,charTokTest)
+
+-- | Generic class for float parsers. Can be used to parse floats from raw
+-- characters (useful at runtime) or from tokenized text (for parsing source).
+class FloatParser tok st where
+ digitP :: GenParser tok st Char
+ dotP :: GenParser tok st Char
+ plusP :: GenParser tok st Char
+ minusP :: GenParser tok st Char
+ charEP :: GenParser tok st Char
+
+ floatP :: GenParser tok st Float
+ floatP = do
+ sgn <- option "" sgnP
+ mant <- try float2P <|> float1P
+ expt <- option "" expP
+ return (read (sgn++mant++expt))
+
+ float1P :: GenParser tok st String
+ float1P = many1 digitP
+
+ float2P :: GenParser tok st String
+ float2P = do
+ i <- many digitP
+ dotP
+ f <- many digitP
+ return ("0"++i++"."++f++"0")
+
+ sgnP :: GenParser tok st String
+ sgnP = do
+ sgn <- plusP <|> minusP
+ return (if sgn == '+' then "" else "-")
+
+ expP :: GenParser tok st String
+ expP = do
+ charEP
+ esgn <- option "" sgnP
+ i <- many1 digitP
+ return ("E"++esgn++i)
+
+instance FloatParser Char st where
+ digitP = digit
+ dotP = char '.'
+ plusP = char '+'
+ minusP = char '-'
+ charEP = char 'E' <|> char 'e'
+
+instance FloatParser (Tagged Token) () where
+ digitP = do tok <- tokenP (charTokTest isDigit)
+ return (getCharTokChar $ getTaggedVal tok)
+ dotP = tokenP (==DotTok) >> return '.'
+ plusP = tokenP (==PlusTok) >> return '+'
+ minusP = tokenP (==MinusTok) >> return '-'
+ charEP = tokenP (charTokTest (=='E')) >> return 'E'
diff --git a/src/Language/VintageBasic/Interpreter.hs b/src/Language/VintageBasic/Interpreter.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/Interpreter.hs
@@ -0,0 +1,528 @@
+{-# LANGUAGE FlexibleContexts, ParallelListComp, Rank2Types #-}
+
+-- | The heart of the BASIC interpreter. It is implemented on top
+-- of the BASIC monad.
+
+module Language.VintageBasic.Interpreter(interpLines) where
+
+import Control.Monad.CPST.DurableTraps
+import Data.List
+import Data.Maybe
+import Language.VintageBasic.Builtins(Builtin(..))
+import Language.VintageBasic.LexCommon(Tagged(..))
+import Language.VintageBasic.BasicMonad
+import Language.VintageBasic.Result
+import Language.VintageBasic.Printer(printFloat)
+import Language.VintageBasic.RuntimeParser(dataValsP,readFloat,trim)
+import Language.VintageBasic.Syntax
+import Text.ParserCombinators.Parsec(parse)
+import Text.ParserCombinators.Parsec.Pos(sourceLine)
+
+-- | Entry in the jump table, a lookup table that holds both
+-- program code and @DATA@ statements, indexed by 'Label'.
+data JumpTableEntry = JumpTableEntry {
+ jtLabel :: Label, -- ^ the starting line number
+ jtProgram :: Program, -- ^ program source starting at that line
+ jtData :: [String] -- ^ @DATA@ strings starting at that line
+}
+
+type JumpTable = [JumpTableEntry]
+
+programLookup :: JumpTable -> Label -> (Maybe Program)
+programLookup jt lab = lookup lab [(jtLabel jte, jtProgram jte) | jte <- jt]
+
+dataLookup :: JumpTable -> Label -> (Maybe [String])
+dataLookup jt lab = lookup lab [(jtLabel jte, jtData jte) | jte <- jt]
+
+-- | Lazily interprets a list of BASIC lines of code.
+
+interpLines :: [Line] -> Program
+
+-- Note that jumpTable and interpLine are mutually recursive.
+-- The jumpTable contains interpreted code, which in turn calls
+-- the jumpTable to look up code. Since the jumpTable is a single
+-- data structure, it memoizes interpreted code, making 'interpLines'
+-- a just-in-time compiler. (The only time code is reinterpreted
+-- is following an @IF@ statement.)
+
+interpLines progLines =
+ let interpLine line@(Line lab stmts) =
+ (lab, mapM_ (interpTS jumpTable) stmts, dataFromLine line)
+ makeTableEntry (accumCode, accumData) (lab, codeSeg, lineData) =
+ let accumCode' = codeSeg >> accumCode
+ accumData' = lineData ++ accumData
+ in ((accumCode', accumData'), JumpTableEntry lab accumCode' accumData')
+ jumpTable = snd $ mapAccumR makeTableEntry (done, []) $ map interpLine progLines
+ in do
+ case jumpTable of
+ ((JumpTableEntry _ prog dat) : _) -> do
+ seedRandomFromTime
+ setDataStrings dat
+ prog
+ [] -> done
+
+-- Expression evaluation
+
+boolToVal :: Bool -> Val
+boolToVal t = if t then FloatVal (-1) else FloatVal 0
+
+isNext :: Result -> Bool
+isNext (LabeledRuntimeException _ (Next Nothing)) = True
+isNext _ = False
+
+isNextVar :: VarName -> Result -> Bool
+isNextVar (VarName FloatType v1) (LabeledRuntimeException _ (Next (Just v2))) = v1==v2
+isNextVar _ _ = False
+
+isReturn :: Result -> Bool
+isReturn (LabeledRuntimeException _ Return) = True
+isReturn _ = False
+
+liftFVOp1 :: (Float -> Float) -> Val -> Code Val
+liftFVOp1 f (FloatVal v1) = return $ FloatVal $ f v1
+liftFVOp1 _ _ = typeMismatch
+
+liftFVBuiltin1 :: (Float -> Float) -> [Val] -> Code Val
+liftFVBuiltin1 f [FloatVal v1] = return $ FloatVal $ f v1
+liftFVBuiltin1 _ [_] = typeMismatch
+liftFVBuiltin1 _ _ = wrongNumArgs
+
+liftFVOp2 :: (Float -> Float -> Float) -> Val -> Val -> Code Val
+liftFVOp2 f (FloatVal v1) (FloatVal v2) = return $ FloatVal $ f v1 v2
+liftFVOp2 _ _ _ = typeMismatch
+
+liftSVOp2 :: (String -> String -> String) -> Val -> Val -> Code Val
+liftSVOp2 f (StringVal v1) (StringVal v2) = return $ StringVal $ f v1 v2
+liftSVOp2 _ _ _ = typeMismatch
+
+liftFSCmpOp2 :: (forall a. Ord a => a -> a -> Bool) -> Val -> Val -> Code Val
+liftFSCmpOp2 f v1 v2 = do
+ assert (typeOf v1 == typeOf v2) TypeMismatchError
+ return $ boolToVal $ f v1 v2
+
+valError :: RuntimeError -> Code Val
+-- The return (FloatVal 0) will never be executed, but is needed to make the types work out.
+valError err = raiseRuntimeError err >> return (FloatVal 0)
+
+wrongNumArgs, typeMismatch, invalidArgument, divisionByZero :: Code Val
+wrongNumArgs = valError WrongNumberOfArgumentsError
+typeMismatch = valError TypeMismatchError
+invalidArgument = valError InvalidArgumentError
+divisionByZero = valError DivisionByZeroError
+
+-- | Evaluate a BASIC expression.
+eval :: Expr -> Code Val
+eval (LitX (FloatLit v)) = return (FloatVal v)
+eval (LitX (StringLit v)) = return (StringVal v)
+eval (VarX var) = getVar var
+eval (FnX var xs) = do
+ fn <- getFn var
+ vals <- mapM eval xs
+ fn vals
+eval (MinusX x) = do
+ val <- eval x
+ liftFVOp1 negate val
+eval (NotX x) = do
+ val <- eval x
+ liftFVOp1 (\v -> if v==0 then -1 else 0) val
+eval (BinX op x1 x2) = do
+ v1 <- eval x1
+ v2 <- eval x2
+ evalBinOp op v1 v2
+eval (BuiltinX b xs) = do
+ vs <- mapM eval xs
+ evalBuiltin b vs
+eval NextZoneX = do
+ curCol <- getOutputColumn
+ let numSpaces = zoneWidth - (curCol `mod` zoneWidth)
+ return $ StringVal $ replicate numSpaces ' '
+eval EmptySeparatorX = return $ StringVal ""
+eval (ParenX x) = eval x
+
+-- | Evaluate an expression with a binary operator.
+evalBinOp :: BinOp -> Val -> Val -> Code Val
+evalBinOp op =
+ case op of
+ AddOp -> \v1 v2 ->
+ case (v1,v2) of
+ (FloatVal _, FloatVal _ ) -> liftFVOp2 (+) v1 v2
+ (StringVal _, StringVal _) -> liftSVOp2 (++) v1 v2
+ (_, _ ) -> typeMismatch
+ SubOp -> liftFVOp2 (-)
+ MulOp -> liftFVOp2 (*)
+ DivOp -> \v1 v2 ->
+ case (v1,v2) of
+ (FloatVal fv1, FloatVal fv2) ->
+ if fv2==0
+ then divisionByZero
+ else return $ FloatVal $ fv1/fv2
+ (_,_) -> typeMismatch
+ PowOp -> liftFVOp2 (**)
+ EqOp -> liftFSCmpOp2 (==)
+ NEOp -> liftFSCmpOp2 (/=)
+ LTOp -> liftFSCmpOp2 (<)
+ LEOp -> liftFSCmpOp2 (<=)
+ GTOp -> liftFSCmpOp2 (>)
+ GEOp -> liftFSCmpOp2 (>=)
+ AndOp -> liftFVOp2 $ \v1 v2 -> if v1/=0 && v2/=0 then v1 else 0
+ OrOp -> liftFVOp2 $ \v1 v2 -> if v1/=0 then v1 else v2
+
+checkArgTypes :: [ValType] -> [Val] -> Code ()
+checkArgTypes types vals = do
+ if length types == length vals
+ then
+ if and [t == typeOf v | t <- types | v <- vals]
+ then return ()
+ else typeMismatch >> return ()
+ else
+ wrongNumArgs >> return ()
+
+-- | Evaluate an expression with a builtin function.
+evalBuiltin :: Builtin -> [Val] -> Code Val
+evalBuiltin builtin args = case builtin of
+ AbsBI -> liftFVBuiltin1 abs args
+ AscBI -> do
+ checkArgTypes [StringType] args
+ let [StringVal v] = args
+ if length v == 0
+ then invalidArgument
+ else return $ FloatVal (fromIntegral (fromEnum (head v)))
+ AtnBI -> liftFVBuiltin1 atan args
+ ChrBI -> do
+ checkArgTypes [FloatType] args
+ let [FloatVal v] = args
+ let iv = floatToInt v
+ if iv < 0 || iv > 255
+ then invalidArgument
+ else return $ StringVal [toEnum iv]
+ CosBI -> liftFVBuiltin1 cos args
+ ExpBI -> liftFVBuiltin1 exp args
+ IntBI -> liftFVBuiltin1 (fromIntegral . floatToInt) args
+ LeftBI -> do
+ checkArgTypes [StringType, FloatType] args
+ let [StringVal sv, FloatVal fv] = args
+ let iv = floatToInt fv
+ if iv < 0
+ then invalidArgument
+ else return (StringVal (take iv sv))
+ LenBI -> do
+ checkArgTypes [StringType] args
+ let [StringVal sv] = args in return (FloatVal (fromIntegral (length sv)))
+ LogBI -> do
+ checkArgTypes [FloatType] args
+ let [FloatVal fv] = args in if fv <= 0 then invalidArgument else return (FloatVal (log fv))
+ MidBI -> case args of
+ [StringVal sv, FloatVal fv] ->
+ let iv = floatToInt fv in
+ if iv < 1
+ then invalidArgument
+ else return (StringVal (drop (iv-1) sv))
+ [_, _] -> typeMismatch
+ [StringVal sv, FloatVal fv1, FloatVal fv2] ->
+ let iv1 = floatToInt fv1
+ iv2 = floatToInt fv2
+ in
+ if iv1 < 1 || iv2 < 0
+ then invalidArgument
+ else return (StringVal (take iv2 (drop (iv1-1) sv)))
+ [_, _, _] -> typeMismatch
+ _ -> wrongNumArgs
+ RightBI -> do
+ checkArgTypes [StringType, FloatType] args
+ let [StringVal sv, FloatVal fv] = args
+ let iv = floatToInt fv
+ if iv < 0
+ then invalidArgument
+ else return (StringVal (drop (length sv - iv) sv))
+ RndBI -> do
+ checkArgTypes [FloatType] args
+ let [FloatVal fv] = args
+ let iv = floatToInt fv
+ if iv < 0
+ then seedRandom iv
+ else return ()
+ rv <- if (iv == 0) then getPrevRandom else getRandom
+ return (FloatVal rv)
+ SgnBI -> liftFVBuiltin1 (\v -> if v < 0 then -1 else if v > 0 then 1 else 0) args
+ SinBI -> liftFVBuiltin1 sin args
+ SpcBI -> do
+ checkArgTypes [FloatType] args
+ let [FloatVal fv] = args
+ let iv = floatToInt fv
+ if iv < 0
+ then invalidArgument
+ else return (StringVal (replicate iv ' '))
+ SqrBI -> do
+ checkArgTypes [FloatType] args
+ let [FloatVal fv] = args
+ if fv < 0
+ then invalidArgument
+ else return (FloatVal (sqrt fv))
+ StrBI -> do
+ checkArgTypes [FloatType] args
+ let [FloatVal fv] = args in return (StringVal (showVal (FloatVal fv)))
+ TabBI -> do
+ checkArgTypes [FloatType] args
+ let [FloatVal fv] = args
+ let destCol = floatToInt fv
+ if (destCol < 0)
+ then invalidArgument
+ else do
+ curCol <- getOutputColumn
+ return $ StringVal $
+ if curCol > destCol
+ then ""
+ else replicate (destCol - curCol) ' '
+ TanBI -> liftFVBuiltin1 tan args
+ ValBI -> do
+ checkArgTypes [StringType] args
+ let [StringVal sv] = args in return (FloatVal (maybe 0 id (readFloat (trim sv))))
+
+-- | Interpret a tagged statement.
+-- Sets the line number in the state, then passes the statement on to interpS.
+interpTS :: JumpTable -> Tagged Statement -> Code ()
+interpTS jumpTable (Tagged pos statement) = do
+ setLineNumber (sourceLine pos)
+ interpS jumpTable statement
+
+-- | Interpret a single statement.
+-- In the type of interpS, the first () signifies what is passed to a
+-- resumed trap. The second one represents what is returned by interpS.
+interpS :: JumpTable -> Statement -> Code ()
+
+interpS _ (RemS _) = return ()
+
+interpS _ EndS = end
+
+interpS _ StopS = end
+
+interpS _ (DimS arrs) = mapM_ interpDim arrs
+
+interpS _ (LetS var x) = do
+ val <- eval x
+ setVar var val
+
+interpS _ (PrintS xs) = do
+ mapM (\x -> eval x >>= printVal) xs
+ if null xs || not (isPrintSeparator (last xs))
+ then printString "\n"
+ else return ()
+
+interpS _ (InputS mPrompt vars) = do
+ case mPrompt of
+ Nothing -> return ()
+ (Just ps) -> printString ps
+ inputVars vars
+
+interpS jumpTable (GotoS lab) = do
+ let maybeCode = programLookup jumpTable lab
+ assert (isJust maybeCode) (BadGotoTargetError lab)
+ fromJust maybeCode >> end
+
+interpS jumpTable (OnGotoS x labs) = interpComputed jumpTable GotoS x labs
+
+interpS jumpTable (OnGosubS x labs) = interpComputed jumpTable GosubS x labs
+
+interpS jumpTable (IfS x sts) = do
+ v <- eval x
+ fv <- extractFloatOrFail TypeMismatchError v
+ if fv == 0
+ then return ()
+ else mapM_ (interpTS jumpTable) sts
+
+-- Note that the loop condition isn't tested until a NEXT is reached.
+-- This is an intentionally authentic feature. In fact, were we to try to
+-- test at the initial FOR, we wouldn't know which NEXT to jump to to skip
+-- the loop - it is undecidable.
+interpS _ (ForS control x1 x2 x3) = do
+ assert (typeOf control == FloatType) TypeMismatchError
+ v1 <- eval x1
+ _ <- extractFloatOrFail TypeMismatchError v1
+ setScalarVar control v1
+ v2 <- eval x2
+ lim <- extractFloatOrFail TypeMismatchError v2
+ v3 <- eval x3
+ step <- extractFloatOrFail TypeMismatchError v3
+ trap $ \ x passOn resume continue ->
+ if isNext x || isNextVar control x
+ then do
+ (FloatVal index) <- getScalarVar control
+ let index' = index+step
+ setScalarVar control (FloatVal index')
+ if (step>=0 && index'<=lim)
+ || (step<0 && index'>=lim)
+ then continue True
+ else resume False
+ else passOn True
+
+interpS _ (NextS Nothing) = raiseRuntimeException (Next Nothing)
+interpS _ (NextS (Just vars)) = mapM_ interpNextVar vars
+
+interpS jumpTable (GosubS lab) =
+ do let maybeCode = programLookup jumpTable lab
+ assert (isJust maybeCode) (BadGosubTargetError lab)
+ catchC gosubHandler (fromJust maybeCode)
+ return ()
+interpS _ ReturnS = raiseRuntimeException Return
+
+interpS _ RandomizeS = seedRandomFromTime
+
+interpS jumpTable (RestoreS maybeLab) = do
+ case maybeLab of
+ (Just lab) -> case dataLookup jumpTable lab of
+ (Just ds) -> setDataStrings ds
+ Nothing -> raiseRuntimeError (BadRestoreTargetError lab)
+ Nothing -> if null jumpTable
+ then return ()
+ else setDataStrings (jtData (head jumpTable))
+
+interpS _ (ReadS vars) = mapM_ interpRead vars
+
+interpS _ (DataS _) = return ()
+
+interpS _ (DefFnS vn params expr) = setFn vn $ \vals -> do
+ assert (length params == length vals) WrongNumberOfArgumentsError
+ assert
+ (and [typeOf p == typeOf v | p <- params | v <- vals])
+ TypeMismatchError
+ stashedVals <- mapM getScalarVar params
+ sequence_ $ zipWith setScalarVar params vals
+ result <- eval expr
+ sequence_ $ zipWith setScalarVar params stashedVals
+ return result
+
+gosubHandler :: BasicExceptionHandler
+gosubHandler x passOn _ continue = if isReturn x then continue False else passOn True
+
+-- | Interpret a computed @GOTO@ or @GOSUB@.
+interpComputed :: JumpTable -> (Label -> Statement) -> Expr -> [Label] -> Code ()
+interpComputed jumpTable cons x labs = do
+ v <- eval x
+ fv <- extractFloatOrFail TypeMismatchError v
+ let i = floatToInt fv
+ if i > 0 && i <= length labs
+ then do
+ let lab = labs !! (i-1)
+ interpS jumpTable (cons lab)
+ else
+ return ()
+
+-- | Interpret a @NEXT@ with a supplied variable.
+interpNextVar :: VarName -> Code ()
+interpNextVar (VarName FloatType v) = raiseRuntimeException (Next (Just v))
+interpNextVar _ = raiseRuntimeError TypeMismatchError
+
+-- | Execute an @INPUT@ statement with a list of input variables.
+inputVars :: [Var] -> Code ()
+inputVars vars = do
+ printString "? "
+ inText <- getString
+ case parse dataValsP "" inText of
+ (Right ivs) -> do
+ let maybeVals = zipWith checkInput vars ivs
+ if or (map isNothing maybeVals)
+ then do
+ printString "!NUMBER EXPECTED - RETRY INPUT LINE\n"
+ inputVars vars
+ else do
+ let vals = map fromJust maybeVals
+ sequence_ (zipWith setVar vars vals)
+ case compare (length vars) (length ivs) of
+ LT -> printString "!EXTRA INPUT IGNORED\n"
+ GT -> do
+ printString "?"
+ inputVars (drop (length vals) vars)
+ EQ -> return ()
+ (Left _) -> error "Mismatched inputbuf in inputVars"
+
+checkInput :: Var -> String -> Maybe Val
+checkInput var s = case typeOf var of
+ StringType -> Just (StringVal s)
+ FloatType -> case readFloat s of
+ (Just v) -> Just (FloatVal v)
+ _ -> Nothing
+ IntType -> case readFloat s of
+ (Just v) -> Just (IntVal (floatToInt v))
+ _ -> Nothing
+
+interpRead :: Var -> Code ()
+interpRead var = do
+ s <- readData
+ case checkInput var s of
+ Nothing -> raiseRuntimeError TypeMismatchError
+ (Just val) -> setVar var val
+
+getVar :: Var -> Code Val
+getVar (ScalarVar vn) = do
+ val <- getScalarVar vn
+ coerceToExpression val
+getVar (ArrVar vn xs) = do
+ inds <- mapM eval xs
+ is <- checkArrInds inds
+ val <- getArrVar vn is
+ coerceToExpression val
+
+setVar :: Var -> Val -> Code ()
+setVar (ScalarVar vn) val = do
+ val' <- coerce vn val
+ setScalarVar vn val'
+setVar (ArrVar vn xs) val = do
+ inds <- mapM eval xs
+ is <- checkArrInds inds
+ val' <- coerce vn val
+ setArrVar vn is val'
+
+-- | Coerce a value to the type it would have in an expression.
+-- Specifically coerces ints to floats.
+coerceToExpression :: Val -> Code Val
+coerceToExpression val = case typeOf val of
+ IntType -> coerce FloatType val
+ _ -> return val
+
+coerce :: Typeable a => a -> Val -> Code Val
+coerce var val = case (typeOf var, val) of
+ (IntType, (FloatVal fv)) -> return $ IntVal (floatToInt fv)
+ (FloatType, (FloatVal _)) -> return val
+ (FloatType, (IntVal iv)) -> return $ FloatVal (fromIntegral iv)
+ (IntType, (IntVal _)) -> return val
+ (StringType, (StringVal _)) -> return val
+ (_, _) -> typeMismatch
+
+interpDim :: (VarName, [Expr]) -> Code ()
+interpDim (vn, xs) = do
+ inds <- mapM eval xs
+ is <- checkArrInds inds
+ -- add 1, so that range is from 0 to user-specified bound
+ let bounds = map (1+) is
+ dimArray vn bounds
+ return ()
+
+checkArrInds :: [Val] -> Basic (BasicExcep Result ()) [Int]
+checkArrInds indVals = do
+ indFs <- mapM (extractFloatOrFail TypeMismatchError) indVals
+ assert (and (map (>=0) indFs)) NegativeArrayDimError
+ let inds = map floatToInt indFs
+ return inds
+
+showVal :: Val -> String
+showVal (FloatVal fv) = printFloat fv
+showVal (IntVal iv) = if iv > 0 then " " else "" ++ show iv
+showVal (StringVal s) = s
+
+printVal :: Val -> Basic o ()
+printVal v =
+ printString (showVal v ++ case v of
+ (FloatVal _) -> " "
+ (IntVal _) -> " "
+ (StringVal _) -> ""
+ )
+
+-- | Extract the @DATA@ strings from a program line.
+dataFromLine :: Line -> [String]
+dataFromLine (Line _ stmts) = concat (map (dataFromStatement . getTaggedVal) stmts)
+
+dataFromStatement :: Statement -> [String]
+dataFromStatement (DataS s) =
+ let (Right ss) = parse dataValsP "" s
+ in ss
+dataFromStatement _ = []
diff --git a/src/Language/VintageBasic/LexCommon.hs b/src/Language/VintageBasic/LexCommon.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/LexCommon.hs
@@ -0,0 +1,36 @@
+-- | Contains a few common definitions for lexing BASIC.
+
+module Language.VintageBasic.LexCommon where
+
+import Text.ParserCombinators.Parsec
+
+-- | A generic structure for tagging code with source positions.
+data Tagged a =
+ Tagged { getPosTag :: SourcePos, getTaggedVal :: a }
+ deriving (Show)
+
+instance (Eq a) => Eq (Tagged a) where
+ (Tagged _ x) == (Tagged _ y) = x == y
+
+-- | Parses a single whitespace character.
+whiteSpaceChar :: Parser Char
+whiteSpaceChar = oneOf " \v\f\t" "SPACE"
+
+-- | Parses a stretch of whitespace.
+whiteSpace :: Parser ()
+whiteSpace = skipMany (whiteSpaceChar "")
+
+-- | Parses a legal BASIC character.
+legalChar :: Parser Char
+legalChar = letter <|> digit <|> oneOf ",:;()$%=<>+-*/^?"
+
+-- | Parses a line number.
+labelP :: Parser Int
+labelP = do
+ s <- many1 (digit "") "LINE NUMBER"
+ return (read s)
+
+-- | Parser tries to apply another parser, returning Just the result
+-- on a match, or Nothing in the case of failure.
+optionally :: GenParser tok st a -> GenParser tok st (Maybe a)
+optionally p = option Nothing (p >>= return . Just)
diff --git a/src/Language/VintageBasic/LineScanner.hs b/src/Language/VintageBasic/LineScanner.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/LineScanner.hs
@@ -0,0 +1,38 @@
+-- | Reads lines of a BASIC program. It does just enough parsing to find
+-- the line number.
+
+module Language.VintageBasic.LineScanner(RawLine,rawLinesP) where
+
+import Text.ParserCombinators.Parsec
+import Language.VintageBasic.LexCommon
+
+type RawLine = Tagged String
+
+eol :: Parser Char
+eol = do
+ optionally (char '\r')
+ newline
+
+blankLineP :: Parser ()
+blankLineP = do
+ eol ""
+ whiteSpace
+
+rawLineP :: Parser RawLine
+rawLineP = do
+ n <- labelP
+ whiteSpace
+ pos <- getPosition
+ s <- manyTill (anyChar "CHARACTER") (eol "END OF LINE")
+ whiteSpace
+ many blankLineP
+ return (Tagged (setSourceLine pos n) s)
+
+rawLinesP :: Parser [RawLine]
+rawLinesP = do
+ whiteSpace
+ many blankLineP
+ ls <- many rawLineP
+ many blankLineP
+ eof "END OF FILE"
+ return ls
diff --git a/src/Language/VintageBasic/Parser.hs b/src/Language/VintageBasic/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/Parser.hs
@@ -0,0 +1,360 @@
+-- | Parses BASIC source code, in tokenized form, to produce abstract syntax.
+-- Also used at runtime to input values.
+
+module Language.VintageBasic.Parser(exprP,statementListP) where
+
+import Data.Char
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Expr
+import Language.VintageBasic.FloatParser
+import Language.VintageBasic.LexCommon
+import Language.VintageBasic.Syntax
+import Language.VintageBasic.Tokenizer
+
+-- | The number of significant letters at the start of a variable name.
+varSignifLetters :: Int
+varSignifLetters = 2
+
+-- | The number of digits (following the letters) of a variable name that are significant.
+varSignifDigits :: Int
+varSignifDigits = 1
+
+type TokParser = GenParser (Tagged Token) ()
+
+skipSpace :: TokParser ()
+skipSpace = skipMany $ tokenP (==SpaceTok)
+
+lineNumP :: TokParser Int
+lineNumP =
+ do s <- many1 (tokenP (charTokTest isDigit) "") "LINE NUMBER"
+ skipSpace
+ return (read (map (getCharTokChar . getTaggedVal) s))
+
+-- LITERALS
+
+floatLitP :: TokParser Literal
+floatLitP =
+ do v <- floatP
+ skipSpace
+ return (FloatLit v)
+
+stringLitP :: TokParser Literal
+stringLitP =
+ do tok <- tokenP isStringTok
+ return (StringLit (getStringTokString (getTaggedVal tok)))
+
+litP :: TokParser Literal
+litP = floatLitP <|> stringLitP
+
+-- VARIABLES
+
+varBaseP :: TokParser String
+varBaseP = do ls <- many1 (tokenP (charTokTest isAlpha))
+ ds <- many (tokenP (charTokTest isDigit))
+ return (taggedCharToksToString (take varSignifLetters ls
+ ++ take varSignifDigits ds))
+
+floatVarNameP :: TokParser VarName
+floatVarNameP = do
+ name <- varBaseP
+ return (VarName FloatType name)
+
+intVarNameP :: TokParser VarName
+intVarNameP = do
+ name <- varBaseP
+ tokenP (==PercentTok)
+ return (VarName IntType name)
+
+stringVarNameP :: TokParser VarName
+stringVarNameP = do
+ name <- varBaseP
+ tokenP (==DollarTok)
+ return (VarName StringType name)
+
+-- Look for string and int vars first because of $ and % suffixes.
+varNameP :: TokParser VarName
+varNameP = do
+ vn <- try stringVarNameP <|> try intVarNameP <|> floatVarNameP
+ skipSpace
+ return vn
+
+scalarVarP :: GenParser (Tagged Token) () Var
+scalarVarP = do
+ vn <- varNameP
+ return (ScalarVar vn)
+
+arrVarP :: GenParser (Tagged Token) () Var
+arrVarP = do
+ vn <- varNameP
+ xs <- argsP
+ return (ArrVar vn xs)
+
+varP :: GenParser (Tagged Token) () Var
+varP = try arrVarP <|> scalarVarP
+
+-- BUILTINS
+
+builtinXP :: TokParser Expr
+builtinXP = do
+ (Tagged _ (BuiltinTok b)) <- tokenP isBuiltinTok
+ xs <- argsP
+ return (BuiltinX b xs)
+
+-- EXPRESSIONS
+
+litXP :: TokParser Expr
+litXP =
+ do v <- litP
+ return (LitX v)
+
+varXP :: TokParser Expr
+varXP =
+ do v <- varP
+ return (VarX v)
+
+argsP :: TokParser [Expr]
+argsP =
+ do tokenP (==LParenTok)
+ xs <- sepBy exprP (tokenP (==CommaTok))
+ tokenP (==RParenTok)
+ return xs
+
+fnXP :: TokParser Expr
+fnXP = do
+ tokenP (==FnTok)
+ vn <- varNameP
+ args <- argsP
+ return (FnX vn args)
+
+parenXP :: TokParser Expr
+parenXP =
+ do tokenP (==LParenTok)
+ x <- exprP
+ tokenP (==RParenTok)
+ return (ParenX x)
+
+primXP :: TokParser Expr
+primXP = parenXP <|> litXP <|> builtinXP <|> fnXP <|> varXP
+
+opTable :: OperatorTable (Tagged Token) () Expr
+opTable =
+ [[prefix MinusTok MinusX, prefix PlusTok id],
+ [binary PowTok (BinX PowOp) AssocRight],
+ [binary MulTok (BinX MulOp) AssocLeft, binary DivTok (BinX DivOp) AssocLeft],
+ [binary PlusTok (BinX AddOp) AssocLeft, binary MinusTok (BinX SubOp) AssocLeft],
+ [binary EqTok (BinX EqOp) AssocLeft, binary NETok (BinX NEOp) AssocLeft,
+ binary LTTok (BinX LTOp) AssocLeft, binary LETok (BinX LEOp) AssocLeft,
+ binary GTTok (BinX GTOp) AssocLeft, binary GETok (BinX GEOp) AssocLeft],
+ [prefix NotTok NotX],
+ [binary AndTok (BinX AndOp) AssocLeft],
+ [binary OrTok (BinX OrOp) AssocLeft]]
+
+binary :: Token -> (Expr -> Expr -> Expr) -> Assoc -> Operator (Tagged Token) () Expr
+binary tok fun assoc =
+ Infix (do tokenP (==tok); return fun) assoc
+prefix :: Token -> (Expr -> Expr) -> Operator (Tagged Token) () Expr
+prefix tok fun =
+ Prefix (do tokenP (==tok); return fun)
+
+-- | Parses a BASIC expression from tokenized source.
+exprP :: TokParser Expr
+exprP = buildExpressionParser opTable primXP
+
+-- STATEMENTS
+
+letSP :: TokParser Statement
+letSP = do
+ optionally (tokenP (==LetTok))
+ v <- varP
+ tokenP (==EqTok)
+ x <- exprP
+ return (LetS v x)
+
+gotoSP :: TokParser Statement
+gotoSP = do
+ try (tokenP (==GoTok) >> tokenP (==ToTok))
+ n <- lineNumP
+ return (GotoS n)
+
+gosubSP :: TokParser Statement
+gosubSP = do
+ try (tokenP (==GoTok) >> tokenP (==SubTok))
+ n <- lineNumP
+ return (GosubS n)
+
+returnSP :: TokParser Statement
+returnSP =
+ do tokenP (==ReturnTok)
+ return ReturnS
+
+onGotoSP :: TokParser Statement
+onGotoSP = try $ do
+ tokenP (==OnTok)
+ x <- exprP
+ tokenP (==GoTok)
+ tokenP (==ToTok)
+ ns <- sepBy1 lineNumP (tokenP (==CommaTok))
+ return (OnGotoS x ns)
+
+onGosubSP :: TokParser Statement
+onGosubSP = try $ do
+ tokenP (==OnTok)
+ x <- exprP
+ tokenP (==GoTok)
+ tokenP (==SubTok)
+ ns <- sepBy1 lineNumP (tokenP (==CommaTok))
+ return (OnGosubS x ns)
+
+ifSP :: TokParser Statement
+ifSP =
+ do tokenP (==IfTok)
+ x <- exprP
+ tokenP (==ThenTok)
+ target <- try ifSPGoto <|> statementListP
+ return (IfS x target)
+
+ifSPGoto :: TokParser [Tagged Statement]
+ifSPGoto =
+ do pos <- getPosition
+ n <- lineNumP
+ return [Tagged pos (GotoS n)]
+
+forSP :: TokParser Statement
+forSP = do
+ tokenP (==ForTok)
+ vn <- varNameP
+ tokenP (==EqTok)
+ x1 <- exprP
+ tokenP (==ToTok)
+ x2 <- exprP
+ x3 <- option (LitX (FloatLit 1)) (tokenP (==StepTok) >> exprP)
+ return (ForS vn x1 x2 x3)
+
+-- | Parses a @NEXT@ and an optional variable list.
+nextSP :: TokParser Statement
+nextSP = do
+ tokenP (==NextTok)
+ vns <- sepBy varNameP (tokenP (==CommaTok))
+ if length vns > 0
+ then return (NextS (Just vns))
+ else return (NextS Nothing)
+
+printSP :: TokParser Statement
+printSP =
+ do tokenP (==PrintTok)
+ xs <- many printExprP
+ return (PrintS xs)
+
+printExprP :: TokParser Expr
+printExprP = emptySeparatorP <|> nextZoneP <|> exprP
+
+emptySeparatorP :: TokParser Expr
+emptySeparatorP = do
+ tokenP (==SemiTok)
+ return EmptySeparatorX
+
+nextZoneP :: TokParser Expr
+nextZoneP = do
+ tokenP (==CommaTok)
+ return NextZoneX
+
+inputSP :: TokParser Statement
+inputSP =
+ do tokenP (==InputTok)
+ ps <- option Nothing inputPrompt
+ vs <- sepBy1 varP (tokenP (==CommaTok))
+ return (InputS ps vs)
+
+inputPrompt :: TokParser (Maybe String)
+inputPrompt =
+ do (StringLit p) <- stringLitP
+ tokenP (==SemiTok)
+ return (Just p)
+
+endSP :: TokParser Statement
+endSP =
+ do tokenP (==EndTok)
+ return EndS
+
+stopSP :: TokParser Statement
+stopSP =
+ do tokenP (==StopTok)
+ return StopS
+
+arrDeclP :: TokParser (VarName, [Expr])
+arrDeclP = do
+ vn <- varNameP
+ xs <- argsP
+ skipSpace
+ return (vn, xs)
+
+dimSP :: TokParser Statement
+dimSP = do
+ tokenP (==DimTok)
+ arrDecls <- sepBy1 arrDeclP (tokenP (==CommaTok))
+ return (DimS arrDecls)
+
+randomizeSP :: TokParser Statement
+randomizeSP = do
+ _ <- tokenP (==RandomizeTok)
+ return RandomizeS
+
+readSP :: TokParser Statement
+readSP = do
+ tokenP (==ReadTok)
+ vs <- sepBy1 varP (tokenP (==CommaTok))
+ return (ReadS vs)
+
+restoreSP :: TokParser Statement
+restoreSP = do
+ tokenP (==RestoreTok)
+ maybeLineNum <- optionally lineNumP
+ return (RestoreS maybeLineNum)
+
+dataSP :: TokParser Statement
+dataSP = do
+ (Tagged _ (DataTok s)) <- tokenP isDataTok
+ return (DataS s)
+
+defFnSP :: TokParser Statement
+defFnSP = do
+ tokenP (==DefTok)
+ tokenP (==FnTok)
+ name <- varNameP
+ tokenP (==LParenTok)
+ params <- sepBy1 varNameP (tokenP (==CommaTok))
+ tokenP (==RParenTok)
+ tokenP (==EqTok)
+ expr <- exprP
+ return (DefFnS name params expr)
+
+remSP :: TokParser Statement
+remSP =
+ do tok <- tokenP isRemTok
+ return (RemS (getRemTokString (getTaggedVal tok)))
+
+statementP :: TokParser (Tagged Statement)
+statementP = do
+ input <- getInput
+ let pos = getPosTag (head input)
+ st <- choice [printSP, inputSP, gotoSP, gosubSP, returnSP, onGotoSP, onGosubSP,
+ ifSP, forSP, nextSP, endSP, stopSP, randomizeSP, dimSP, readSP, restoreSP, dataSP,
+ remSP, defFnSP, letSP]
+ return (Tagged pos st)
+
+-- | Parses a list of statements from a tokenized BASIC source line.
+statementListP :: TokParser [Tagged Statement]
+statementListP = do
+ many (tokenP (==ColonTok))
+ sl <- sepEndBy1 statementP (many1 (tokenP (==ColonTok)))
+ eol ": OR END OF LINE"
+ return sl
+
+anyTokenP :: TokParser (Tagged Token)
+anyTokenP = tokenP (const True)
+
+eol :: TokParser ()
+eol = try (do {
+ tok <- anyTokenP;
+ unexpected (printToken (getTaggedVal tok));
+ } <|> return ()) "END OF LINE"
diff --git a/src/Language/VintageBasic/Printer.hs b/src/Language/VintageBasic/Printer.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/Printer.hs
@@ -0,0 +1,146 @@
+-- | Prettyprinter for BASIC syntax and values.
+
+module Language.VintageBasic.Printer where
+
+import Numeric
+import Data.List
+import Language.VintageBasic.LexCommon
+import Language.VintageBasic.Syntax
+import Language.VintageBasic.Builtins(Builtin,builtinToStrAssoc)
+import Data.Maybe(fromJust)
+
+-- | Prettyprint a BASIC literal.
+printLit :: Literal -> String
+printLit (FloatLit v) = let i = floor v :: Integer
+ in if fromInteger i == v
+ then show i
+ else show v
+printLit (StringLit s) = show s
+
+-- | Prettyprint a floating point value, BASIC style.
+printFloat :: Float -> String
+printFloat x | x == 0 = " 0"
+printFloat x | x < 0 = "-" ++ printPosFloat (-x)
+printFloat x | x > 0 = " " ++ printPosFloat x
+printFloat _ = error "illegal number for printFloat"
+
+-- | The maximum number of decimal digits needed to display the mantissa of a
+-- Float. For IEEE 754-2008 binary32 format, this is 8 decimal digits.
+maxFloatDigits :: Int
+maxFloatDigits = ceiling (log 2 / log 10 * fromIntegral(floatDigits (0::Float)) :: Float)
+
+printPosFloat :: Float -> String
+printPosFloat x =
+ let (digits, ex) = floatToDigits 10 x
+ in
+ if ex <= maxFloatDigits && length digits - ex <= maxFloatDigits
+ then
+ if ex >= length digits
+ then concatMap show (padDigitsRight digits ex)
+ else
+ if ex > 0
+ then concatMap show (take ex digits) ++ "."
+ ++ concatMap show (drop ex digits)
+ else "." ++ concatMap show (padDigitsLeft digits ex)
+ else
+ concatMap show (take 1 digits) ++ "."
+ ++ concatMap show (drop 1 digits) ++ "E"
+ ++ (if ex >= 1 then "+" else "") ++ show (ex - 1)
+
+padDigitsRight :: [Int] -> Int -> [Int]
+padDigitsRight digits ex = digits ++ replicate (ex - length digits) 0
+
+padDigitsLeft :: [Int] -> Int -> [Int]
+padDigitsLeft digits ex = replicate (-ex) 0 ++ digits
+
+-- | Prettyprint a variable name.
+printVarName :: VarName -> String
+printVarName (VarName varType name) = name ++ case varType of
+ FloatType -> ""
+ IntType -> "%"
+ StringType -> "$"
+
+printVar :: Var -> String
+printVar (ScalarVar vn) = printVarName vn
+printVar (ArrVar vn xs) = printVarName vn ++ printArgs xs
+
+printArgs :: [Expr] -> String
+printArgs xs = "(" ++ concat (intersperse "," (map printExpr xs)) ++ ")"
+
+printOp :: BinOp -> String
+printOp AddOp = "+"
+printOp SubOp = "-"
+printOp MulOp = "*"
+printOp DivOp = "/"
+printOp PowOp = "^"
+printOp EqOp = "="
+printOp NEOp = "<>"
+printOp LTOp = "<"
+printOp LEOp = "<="
+printOp GTOp = ">"
+printOp GEOp = ">="
+printOp AndOp = " AND "
+printOp OrOp = " OR "
+
+printBuiltin :: Builtin -> String
+printBuiltin b = fromJust $ lookup b builtinToStrAssoc
+
+printExpr :: Expr -> String
+printExpr (LitX lit) = printLit lit
+printExpr (VarX var) = printVar var
+printExpr (FnX vn xs) = printVarName vn ++ printArgs xs
+printExpr (MinusX x) = "-" ++ printExpr x
+printExpr NextZoneX = ","
+printExpr EmptySeparatorX = ";"
+printExpr (NotX x) = "NOT " ++ printExpr x
+printExpr (ParenX x) = "(" ++ printExpr x ++ ")"
+printExpr (BinX op x1 x2) = printExpr x1 ++ printOp op ++ printExpr x2
+printExpr (BuiltinX b xs) = printBuiltin b ++ printArgs xs
+
+printTaggedStatement :: Tagged Statement -> String
+printTaggedStatement (Tagged _ statement) = printStatement statement
+
+printStatement :: Statement -> String
+printStatement (LetS v x) = "LET " ++ printVar v ++ "=" ++ printExpr x
+printStatement (DimS arrs) =
+ "DIM " ++ concat (intersperse "," [printVarName vn ++ printArgs xs | (vn, xs) <- arrs])
+printStatement (GotoS label) = "GOTO " ++ show label
+printStatement (GosubS label) = "GOSUB " ++ show label
+printStatement (OnGotoS x labels) = "ON " ++ printExpr x ++ " GOTO " ++ (concat (intersperse ", " (map show labels)))
+printStatement (OnGosubS x labels) = "ON " ++ printExpr x ++ " GOSUB " ++ (concat (intersperse ", " (map show labels)))
+printStatement ReturnS = "RETURN"
+printStatement (IfS x ss) =
+ "IF " ++ printExpr x ++ " THEN " ++ printStatementList ss
+printStatement (ForS vn x1 x2 x3) =
+ "FOR " ++ printVarName vn ++ "=" ++ printExpr x1 ++ " TO " ++ printExpr x2
+ ++ (case x3
+ of (LitX (FloatLit 1)) -> ""
+ _ -> " STEP " ++ printExpr x3)
+printStatement (NextS Nothing) = "NEXT"
+printStatement (NextS (Just vns)) =
+ "NEXT " ++ (concat $ intersperse "," (map printVarName vns))
+printStatement (PrintS xs) =
+ "PRINT " ++ (concat $ intersperse " " (map printExpr xs))
+printStatement (InputS prompt vs) =
+ "INPUT " ++ (case prompt of Nothing -> ""; Just ps -> show ps ++ ";")
+ ++ (concat $ intersperse "," (map printVar vs))
+printStatement EndS = "END"
+printStatement StopS = "STOP"
+printStatement RandomizeS = "RANDOMIZE"
+printStatement (ReadS vars) = "READ " ++ (concat (intersperse ", " (map printVar vars)))
+printStatement (RestoreS Nothing) = "RESTORE"
+printStatement (RestoreS (Just n)) = "RESTORE " ++ show n
+printStatement (DataS s) = "DATA " ++ s
+printStatement (DefFnS vn vns x) =
+ "DEF FN" ++ printVarName vn ++ "(" ++ (concat (intersperse ", " (map printVarName vns))) ++ ")"
+ ++ " = " ++ printExpr x
+printStatement (RemS s) = "REM" ++ s
+
+printStatementList :: [Tagged Statement] -> String
+printStatementList ss = concat $ intersperse ":" (map printTaggedStatement ss)
+
+printLine :: Line -> String
+printLine (Line n ss) = show n ++ " " ++ printStatementList ss ++ "\n"
+
+printLines :: [Line] -> String
+printLines progLines = concatMap printLine progLines
diff --git a/src/Language/VintageBasic/Result.hs b/src/Language/VintageBasic/Result.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/Result.hs
@@ -0,0 +1,85 @@
+-- | Results of BASIC computations, including errors.
+
+module Language.VintageBasic.Result(Result(..),RuntimeException(..),RuntimeError(..)) where
+
+import Control.Monad.CPST.DurableTraps(ResultType(..))
+import Language.VintageBasic.Printer(printVarName)
+import Language.VintageBasic.Syntax(Label,VarName)
+import Text.ParserCombinators.Parsec(sourceLine,sourceColumn)
+import Text.ParserCombinators.Parsec.Error(ParseError,errorMessages,errorPos,showErrorMessages)
+
+-- | The ultimate result value of a BASIC program.
+data Result =
+ Pass -- ^ normal termination
+ | ScanError ParseError -- ^ error in scanning line numbers
+ | SyntaxError ParseError -- ^ tokenization or parsing error
+ | LabeledRuntimeException Label RuntimeException -- ^ runtime exception (with line number)
+
+instance ResultType Result where
+ okValue = Pass
+
+data RuntimeException =
+ RuntimeError RuntimeError
+ | Next (Maybe String) -- ^ generated by @NEXT@
+ | Return -- ^ generated by @RETURN@
+
+instance Show Result where
+ show Pass = "NORMAL TERMINATION"
+ show (ScanError pe) = showParseError "LINE NUMBERING" "RAW LINE" "END OF FILE" pe
+ show (SyntaxError pe) = showParseError "SYNTAX" "LINE" "END OF LINE" pe
+ show (LabeledRuntimeException label x) = show x ++ " IN LINE " ++ show label
+
+instance Show RuntimeException where
+ show (RuntimeError err) = show err
+ show (Next Nothing) = "!NEXT WITHOUT FOR ERROR"
+ show (Next (Just s)) = "!NEXT WITHOUT FOR ERROR (VAR "++s++")"
+ show Return = "!RETURN WITHOUT GOSUB ERROR"
+
+data RuntimeError =
+ TypeMismatchError
+ | WrongNumberOfArgumentsError
+ | InvalidArgumentError
+ | DivisionByZeroError
+ | BadGotoTargetError Label
+ | BadGosubTargetError Label
+ | BadRestoreTargetError Label
+ | NegativeArrayDimError
+ | ReDimensionedArrayError
+ | MismatchedArrayDimensionsError
+ | OutOfArrayBoundsError
+ | UndefinedFunctionError VarName
+ | OutOfDataError
+ | EndOfInputError
+ deriving Eq
+
+instance Show RuntimeError where
+ show TypeMismatchError = "!TYPE MISMATCH"
+ show WrongNumberOfArgumentsError = "!WRONG NUMBER OF ARGUMENTS"
+ show InvalidArgumentError = "!INVALID ARGUMENT"
+ show DivisionByZeroError = "!DIVISION BY ZERO"
+ show (BadGotoTargetError lab) = "!BAD GOTO TARGET " ++ show lab
+ show (BadGosubTargetError lab) = "!BAD GOSUB TARGET " ++ show lab
+ show (BadRestoreTargetError lab) = "!BAD RESTORE TARGET " ++ show lab
+ show NegativeArrayDimError = "!NEGATIVE ARRAY DIM"
+ show ReDimensionedArrayError = "!REDIM'D ARRAY"
+ show MismatchedArrayDimensionsError = "!MISMATCHED ARRAY DIMENSIONS"
+ show OutOfArrayBoundsError = "!OUT OF ARRAY BOUNDS"
+ show (UndefinedFunctionError vn) = "!UNDEFINED FUNCTION " ++ printVarName vn
+ show OutOfDataError = "!OUT OF DATA"
+ show EndOfInputError = "!END OF INPUT"
+
+showParseError
+ :: String -- ^ message describing the type of error
+ -> String -- ^ description of source line: @LINE@ or @RAW LINE@
+ -> String -- ^ what to call end of input
+ -> ParseError -- ^ the parse error to show as text
+ -> String
+showParseError msgErrorType msgLine msgEndOfInput parseError =
+ let pos = errorPos parseError
+ messages = errorMessages parseError
+ line = sourceLine pos
+ col = sourceColumn pos
+ in
+ "!" ++ msgErrorType ++ " ERROR IN " ++ msgLine ++ " " ++ show line
+ ++ ", COLUMN " ++ show col
+ ++ showErrorMessages "OR" " UNKNOWN" " EXPECTING" " UNEXPECTED" msgEndOfInput messages
diff --git a/src/Language/VintageBasic/RuntimeParser.hs b/src/Language/VintageBasic/RuntimeParser.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/RuntimeParser.hs
@@ -0,0 +1,38 @@
+-- | Parsing for @DATA@ statements and the @INPUT@ buffer.
+
+module Language.VintageBasic.RuntimeParser(dataValsP,readFloat,trim) where
+
+import Language.VintageBasic.FloatParser(floatP)
+import Text.ParserCombinators.Parsec
+
+-- | Attempts to parse a floating point value from a string.
+readFloat :: String -> Maybe Float
+readFloat s =
+ case parse floatP "" s
+ of (Right fv) -> Just fv
+ _ -> Nothing
+
+nonCommaP :: Parser Char
+nonCommaP = satisfy (/=',')
+
+stringP :: Parser String
+stringP =
+ do char '"'
+ s <- manyTill anyChar (char '"')
+ spaces
+ return s
+
+-- | Trim leading and trailing space from a string.
+trim :: String -> String
+trim s = dropWhile (==' ') $ reverse $ dropWhile (==' ') $ reverse s
+
+-- | Parse a single data value.
+dataValP :: Parser String
+dataValP = do
+ spaces
+ stringP <|> do { s <- many nonCommaP; return (trim s) }
+
+-- | Parse a list of data values.
+-- Works for both @INPUT@ text and @DATA@ statements.
+dataValsP :: Parser [String]
+dataValsP = sepBy1 dataValP (char ',')
diff --git a/src/Language/VintageBasic/Syntax.hs b/src/Language/VintageBasic/Syntax.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/Syntax.hs
@@ -0,0 +1,96 @@
+-- | Describes the abstract syntax of BASIC.
+
+module Language.VintageBasic.Syntax where
+
+import Language.VintageBasic.Builtins(Builtin)
+import Language.VintageBasic.LexCommon(Tagged(..))
+
+-- | A BASIC line number.
+type Label = Int
+
+-- | BASIC value types. The IntType is used for storage or function arguments
+-- but is always converted to FloatType for use in expressions.
+data ValType = FloatType | IntType | StringType
+ deriving (Show,Eq)
+
+class Typeable a where
+ typeOf :: a -> ValType
+
+instance Typeable ValType where
+ typeOf = id
+
+data Literal =
+ FloatLit Float
+ | StringLit String
+ deriving (Show,Eq)
+
+instance Typeable Literal where
+ typeOf (FloatLit _) = FloatType
+ typeOf (StringLit _) = StringType
+
+data VarName = VarName ValType String
+ deriving (Show,Eq)
+
+instance Typeable VarName where
+ typeOf (VarName valType _) = valType
+
+data Var = ScalarVar VarName | ArrVar VarName [Expr]
+ deriving (Show,Eq)
+
+instance Typeable Var where
+ typeOf (ScalarVar varName) = typeOf varName
+ typeOf (ArrVar varName _) = typeOf varName
+
+-- | BASIC binary operators.
+data BinOp =
+ AddOp | SubOp | MulOp | DivOp | PowOp
+ | EqOp | NEOp | LTOp | LEOp | GTOp | GEOp
+ | AndOp | OrOp
+ deriving (Enum,Show,Eq)
+
+-- | BASIC expressions.
+data Expr =
+ LitX Literal
+ | VarX Var
+ | FnX VarName [Expr]
+ | MinusX Expr
+ | NotX Expr
+ | BinX BinOp Expr Expr
+ | BuiltinX Builtin [Expr]
+ | NextZoneX -- ^ commas in a @PRINT@ statement
+ | EmptySeparatorX -- ^ semicolons in a @PRINT@ statement
+ | ParenX Expr
+ deriving (Show,Eq)
+
+isPrintSeparator :: Expr -> Bool
+isPrintSeparator NextZoneX = True
+isPrintSeparator EmptySeparatorX = True
+isPrintSeparator _ = False
+
+-- | BASIC statements.
+data Statement =
+ LetS Var Expr
+ | DimS [(VarName, [Expr])]
+ | GotoS Label
+ | GosubS Label
+ | OnGotoS Expr [Label]
+ | OnGosubS Expr [Label]
+ | ReturnS
+ | IfS Expr [Tagged Statement] -- ^ includes all statements on the line following the @IF@
+ | ForS VarName Expr Expr Expr
+ | NextS (Maybe [VarName])
+ | PrintS [Expr]
+ | InputS (Maybe String) [Var]
+ | EndS
+ | StopS
+ | RandomizeS
+ | ReadS [Var]
+ | RestoreS (Maybe Label)
+ | DataS String
+ | DefFnS VarName [VarName] Expr
+ | RemS String
+ deriving (Show,Eq)
+
+-- | A line of BASIC, in fully parsed form, ready for interpretation.
+data Line = Line Label [Tagged Statement]
+ deriving (Show)
diff --git a/src/Language/VintageBasic/Tokenizer.hs b/src/Language/VintageBasic/Tokenizer.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/VintageBasic/Tokenizer.hs
@@ -0,0 +1,173 @@
+-- | Finds and tokenizes BASIC keywords, in preparation for parsing. This allows
+-- keywords to be read even if there are no spaces around them. Even though
+-- the standard disallows it, many BASIC implementations allowed this to save
+-- memory or screen real estate. The down side is that longer variable names
+-- are not practical, since they might contain keywords.
+
+module Language.VintageBasic.Tokenizer
+ (Token(..),TokenizedLine,isDataTok,isRemTok,charTokTest,taggedCharToksToString,isStringTok,
+ isBuiltinTok,taggedTokensP,tokenP,printToken) where
+
+import Data.Char(toUpper)
+import Language.VintageBasic.Builtins(Builtin,builtinToStrAssoc)
+import Language.VintageBasic.LexCommon
+import Text.ParserCombinators.Parsec
+
+type TokenizedLine = Tagged [Tagged Token]
+
+-- | Parses one or more whitespace characters, producing a space token.
+spaceTokP :: Parser Token
+spaceTokP = whiteSpaceChar >> whiteSpace >> return SpaceTok
+
+data Token = StringTok { getStringTokString :: String } | RemTok { getRemTokString :: String }
+ | DataTok { getDataTokString :: String }
+ | CommaTok | ColonTok | SemiTok | LParenTok | RParenTok
+ | DollarTok | PercentTok
+ | EqTok | NETok | LETok | LTTok | GETok | GTTok
+ | PlusTok | MinusTok | MulTok | DivTok | PowTok
+ | AndTok | OrTok | NotTok
+ | BuiltinTok Builtin
+ | LetTok | DimTok | OnTok | GoTok | SubTok | ReturnTok
+ | IfTok | ThenTok | ForTok | ToTok | StepTok | NextTok
+ | PrintTok | InputTok | RandomizeTok | ReadTok | RestoreTok
+ | DefTok | FnTok | EndTok | StopTok
+ | SpaceTok | DotTok | CharTok { getCharTokChar :: Char }
+ deriving (Eq,Show)
+
+keyword :: String -> Parser String
+keyword s = try (string s) ("keyword " ++ s)
+
+stringTokP :: Parser Token
+-- no special escape chars allowed
+stringTokP =
+ do char '"'
+ s <- manyTill anyChar (char '"')
+ whiteSpace
+ return (StringTok s)
+
+isStringTok :: Token -> Bool
+isStringTok (StringTok _) = True
+isStringTok _ = False
+
+remTokP :: Parser Token
+remTokP = do keyword "REM"
+ s <- many anyChar
+ return (RemTok s)
+
+isRemTok :: Token -> Bool
+isRemTok (RemTok _) = True
+isRemTok _ = False
+
+dataTokP :: Parser Token
+dataTokP =
+ do keyword "DATA"
+ s <- many anyChar
+ return (DataTok s)
+
+isDataTok :: Token -> Bool
+isDataTok (DataTok _) = True
+isDataTok _ = False
+
+charTokP :: Parser Token
+charTokP = do c <- legalChar; return (CharTok (toUpper c))
+
+charTokTest :: (Char -> Bool) -> Token -> Bool
+charTokTest f (CharTok c) = f c
+charTokTest _ _ = False
+
+taggedCharToksToString :: [Tagged Token] -> String
+taggedCharToksToString = map (getCharTokChar . getTaggedVal)
+
+strToTokAssoc :: [(String, Token)]
+strToTokAssoc =
+ [
+ (",", CommaTok),
+ (":", ColonTok),
+ (";", SemiTok),
+ ("(", LParenTok),
+ (")", RParenTok),
+ ("$", DollarTok),
+ ("%", PercentTok),
+ ("=", EqTok),
+ ("<>", NETok),
+ ("<=", LETok),
+ ("<", LTTok),
+ (">=", GETok),
+ (">", GTTok),
+ ("+", PlusTok),
+ ("-", MinusTok),
+ ("*", MulTok),
+ ("/", DivTok),
+ ("^", PowTok),
+ (".", DotTok),
+ ("AND", AndTok),
+ ("OR", OrTok),
+ ("NOT", NotTok),
+ ("LET", LetTok),
+ ("DIM", DimTok),
+ ("ON", OnTok),
+ ("GO", GoTok),
+ ("SUB", SubTok),
+ ("RETURN", ReturnTok),
+ ("IF", IfTok),
+ ("THEN", ThenTok),
+ ("FOR", ForTok),
+ ("TO", ToTok),
+ ("STEP", StepTok),
+ ("NEXT", NextTok),
+ ("PRINT", PrintTok),
+ ("?", PrintTok),
+ ("INPUT", InputTok),
+ ("RANDOMIZE", RandomizeTok),
+ ("READ", ReadTok),
+ ("RESTORE", RestoreTok),
+ ("DEF", DefTok),
+ ("FN", FnTok),
+ ("END", EndTok),
+ ("STOP", StopTok)
+ ] ++ [(s, BuiltinTok b) | (b,s) <- builtinToStrAssoc]
+
+tokToStrAssoc :: [(Token, String)]
+tokToStrAssoc = [(t,s) | (s,t) <- strToTokAssoc]
+
+anyTokP :: Parser Token
+anyTokP = choice ([spaceTokP, stringTokP, remTokP, dataTokP]
+ ++ [do keyword s; whiteSpace; return t | (s,t) <- strToTokAssoc]
+ ++ [charTokP]) "LEGAL BASIC CHARACTER"
+
+isBuiltinTok :: Token -> Bool
+isBuiltinTok (BuiltinTok _) = True
+isBuiltinTok _ = False
+
+taggedTokenP :: Parser (Tagged Token)
+taggedTokenP =
+ do pos <- getPosition
+ tok <- anyTokP
+ return (Tagged pos tok)
+
+-- | The main parser used to read a series of tokens from a string.
+taggedTokensP :: Parser [Tagged Token]
+taggedTokensP =
+ do toks <- many taggedTokenP
+ eof ""
+ return toks
+
+-- | The single-token parser used at the parser level
+tokenP :: (Token -> Bool) -> GenParser (Tagged Token) () (Tagged Token)
+tokenP test = token (printToken . getTaggedVal) getPosTag testTaggedToken
+ where testTaggedToken (Tagged pos tok) =
+ if test tok then Just (Tagged pos tok) else Nothing
+
+-- | Prettyprint a token for error reporting or debugging.
+printToken :: Token -> String
+printToken tok =
+ case (lookup tok tokToStrAssoc) of
+ (Just s) -> s
+ Nothing ->
+ case tok of
+ (CharTok c) -> [c]
+ (DataTok s) -> "DATA" ++ s
+ (RemTok s) -> "REM" ++ s
+ SpaceTok -> " "
+ (StringTok s) -> "\"" ++ s ++ "\""
+ _ -> error "printToken: unrecognized token."
diff --git a/test/Language/VintageBasic/Asserts.hs b/test/Language/VintageBasic/Asserts.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/VintageBasic/Asserts.hs
@@ -0,0 +1,56 @@
+module Language.VintageBasic.Asserts where
+
+import Data.IORef
+import Data.List(isInfixOf)
+import Test.HUnit
+import Text.ParserCombinators.Parsec(eof,parse,sourceLine,sourceColumn,())
+import Language.VintageBasic.LexCommon
+import IO.IOStream
+
+-- | Make an input stream for testing.
+mkInput :: String -> IO IOStream
+mkInput s = do
+ input <- newIORef s
+ return $ IOStream input
+
+-- | Make an empty input stream for testing.
+noInput :: IO IOStream
+noInput = mkInput ""
+
+-- | Make an empty output stream for testing.
+mkOutput :: IO IOStream
+mkOutput = do
+ output <- newIORef ""
+ return $ IOStream output
+
+-- | Assert the output of a program, with empty input.
+assertOutputEq output expected = do
+ got <- vGetContents output
+ assertEqual "Output not as expected" expected got
+
+-- | Extracts line number and token from tagged tokens. Useful for asserting these when you don't care about column number.
+withCol taggedToks = [(sourceColumn pos, tok) | (Tagged pos tok) <- taggedToks]
+
+-- | Extracts line number, column number, and token from tagged tokens. Useful for assertion position and token value.
+withLineAndCol taggedToks = [(sourceLine pos, sourceColumn pos, tok) | (Tagged pos tok) <- taggedToks]
+
+-- | A parser that wraps a check for end of input around another parser.
+-- Useful when checking isolated expressions that don't normally reach end of input.
+parserWithEof parser = do
+ result <- parser
+ eof "END OF INPUT"
+ return result
+
+-- | Assert a parse result, expecting success.
+assertParseResult normalizeResult normalizeError parser input expected = do
+ case parse (parserWithEof parser) "" input of
+ (Left err) -> assertFailure ("Parse error: " ++ show (normalizeError err))
+ (Right rls) -> assertEqual "Parse result not as expected" expected (normalizeResult rls)
+
+-- | Assert an expected parse error.
+assertParseError normalizeResult normalizeError parser input expected = do
+ case parse (parserWithEof parser) "" input of
+ (Left err) -> assertBool
+ ("Parser reported wrong error.\n\nGot:\n" ++ show (normalizeError err) ++ "\n\nExpected error to contain:\n" ++ expected)
+ (isInfixOf expected (show (normalizeError err)))
+ (Right rls) -> assertFailure ("Parser didn't report error, instead got result: " ++ show (normalizeResult rls))
diff --git a/test/Language/VintageBasic/BasicMonad_test.hs b/test/Language/VintageBasic/BasicMonad_test.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/VintageBasic/BasicMonad_test.hs
@@ -0,0 +1,28 @@
+module Language.VintageBasic.BasicMonad_test where
+
+import Data.List(intercalate)
+import Test.HUnit
+import Language.VintageBasic.Asserts
+import Language.VintageBasic.BasicMonad
+import Control.Monad.CPST.DurableTraps
+import IO.IOStream
+
+expectOutput expected code = TestCase $ do
+ input <- noInput
+ output <- mkOutput
+ runProgram input output (code >> done)
+ assertOutputEq output expected
+
+test_printString =
+ expectOutput "first\nsecondthird" $ do
+ printString "first\nsecond"
+ printString "third"
+
+test_output_column =
+ expectOutput "hello\n0;5;0" $ do
+ col1 <- getOutputColumn
+ printString "hello"
+ col2 <- getOutputColumn
+ printString "\n"
+ col3 <- getOutputColumn
+ printString (intercalate ";" [show c | c <- [col1, col2, col3]])
diff --git a/test/Language/VintageBasic/Executer_test.hs b/test/Language/VintageBasic/Executer_test.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/VintageBasic/Executer_test.hs
@@ -0,0 +1,14 @@
+module Language.VintageBasic.Executer_test where
+
+import Data.List(isInfixOf)
+import Test.HUnit
+import Text.ParserCombinators.Parsec.Pos(newPos)
+import Language.VintageBasic.Asserts
+import Language.VintageBasic.Executer
+
+--test_tokenization_errors_reported_at_correct_location = TestCase $ do
+-- let source = (Tagged (newPos "bobble.bas" 10 4) "!")
+-- let expectedError = "(line 10, column 4)"
+-- case tokenizeRawLine source of
+-- (Left err) -> assertBool ("Parser reported wrong error. Got:\n" ++ show err ++ "\nExpected error to contain:\n" ++ expectedError) (isInfixOf expectedError (show err))
+-- (Right rls) -> assertFailure "Parser didn't report error"
diff --git a/test/Language/VintageBasic/FloatParser_test.hs b/test/Language/VintageBasic/FloatParser_test.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/VintageBasic/FloatParser_test.hs
@@ -0,0 +1,45 @@
+module Language.VintageBasic.FloatParser_test where
+
+import Test.HUnit
+import Language.VintageBasic.Asserts
+import Language.VintageBasic.FloatParser
+import Language.VintageBasic.Result
+
+assertFloatPSuccess source expected = assertParseResult id ScanError floatP source expected
+assertFloatPFailure source expected = assertParseError id ScanError floatP source expected
+
+test_successes = TestCase $ do
+ mapM_ (uncurry assertFloatPSuccess) success_cases
+
+success_cases =
+ [
+ ( "0", 0 ),
+ ( ".", 0 ),
+ ( ".25", 0.25 ),
+ ( "123", 123 ),
+ ( "12.", 12 ),
+ ( "-1", -1 ),
+ ( "+12", 12 ),
+ ( ".5", 0.5 ),
+ ( "2.5", 2.5 ),
+ ( "1e2", 100 ),
+ ( "1E2", 100 ),
+ ( "2.5E-1", 0.25 ),
+ ( "+12.5e-2", 0.125 ),
+ ( "+12.5e+2", 1250 )
+ ]
+
+test_failures = TestCase $ do
+ mapM_ (`assertFloatPFailure` "") failure_cases
+
+failure_cases =
+ [
+ "/",
+ "+",
+ "-",
+ "E",
+ "E10",
+ "A",
+ "1E",
+ "1A"
+ ]
diff --git a/test/Language/VintageBasic/Interpreter_test.hs b/test/Language/VintageBasic/Interpreter_test.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/VintageBasic/Interpreter_test.hs
@@ -0,0 +1,588 @@
+module Language.VintageBasic.Interpreter_test where
+
+import Test.HUnit
+import Language.VintageBasic.Asserts
+import Language.VintageBasic.Executer
+import Language.VintageBasic.BasicMonad
+import Control.Monad.CPST.DurableTraps
+
+testProgramOutput source expected = TestCase $ do
+ i <- noInput
+ o <- mkOutput
+ runProgram i o (execute "" source >> done)
+ assertOutputEq o expected
+
+testProgramOutputWithInput source input expected = TestCase $ do
+ i <- mkInput input
+ o <- mkOutput
+ runProgram i o (execute "" source >> done)
+ assertOutputEq o expected
+
+testExpression source expected = testProgramOutput ("1?" ++ source ++ "\n") (expected ++ "\n")
+
+testExpressions ts = TestList $ map (uncurry testExpression) ts
+
+test_does_nothing = testProgramOutput "" ""
+
+test_executes_lines_in_sequence = testProgramOutput "10 ?\"A\"\n20 ?\"B\"\n" "A\nB\n"
+
+test_var_defaults = testProgramOutput "10 ?A:?A%:?A$\n" " 0 \n 0 \n\n"
+
+test_float_assignment = testProgramOutput "10 A=5:PRINTA\n" " 5 \n"
+
+test_int_assignment_pos = testProgramOutput "10 A%=5.9:?A%\n" " 5 \n"
+
+test_int_assignment_neg = testProgramOutput "10 A%=-5.1:?A%\n" "-6 \n"
+
+test_string_assignment = testProgramOutput "10 A$=\"WOW\":?A$\n" "WOW\n"
+
+test_variables_of_different_types_with_the_same_name_are_different = testProgramOutput
+ "10 A=4.5:A%=3:A$=\"HI\"\n20 ?A:?A%:?A$\n"
+ " 4.5 \n 3 \nHI\n"
+
+test_var_names_are_only_significant_to_two_characters = testProgramOutput
+ "10 SOMETHING=4:SAMETHING=2:?SOWHAT:?SALLY\n"
+ " 4 \n 2 \n"
+
+test_first_digit_of_var_name_is_significant_too = testProgramOutput
+ "10 SOMETHING12=4:SOMETHING22=2:?SOMETHING13:?SOMETHING24\n"
+ " 4 \n 2 \n"
+
+test_dim = testProgramOutput "10 DIMA(20):A(0)=5:A(20)=6:PRINTA(20);A(0)\n" " 6 5 \n"
+
+test_dim_default_size_is_at_least_10 = testProgramOutput "10 A(10)=6:PRINTA(10)\n" " 6 \n"
+
+test_dim_default_size_is_at_most_10 = testProgramOutput
+ "10 A(11)=6:PRINTA(11)\n" "!OUT OF ARRAY BOUNDS IN LINE 10\n"
+
+test_dim_with_negative_dimension = testProgramOutput
+ "10 DIMA(-1)\n"
+ "!NEGATIVE ARRAY DIM IN LINE 10\n"
+
+test_multiple_dimensions = testProgramOutput "10 DIMA(1,3):A(1,3)=12:PRINTA(1,3)\n" " 12 \n"
+
+test_array_dim_rounding = testProgramOutput
+ "10 DIMA(11.9):A(11.9)=5:?A(11.1):A(12)=6:?A(6)\n"
+ " 5 \n!OUT OF ARRAY BOUNDS IN LINE 10\n"
+
+test_for_loop_with_array = testProgramOutput "10 FORI=1TO10:A(I)=10-I:NEXT:PRINTA(3)\n" " 7 \n"
+
+test_int_array = testProgramOutput "10 A%(5)=2.8:?A%(1);A%(5)\n" " 0 2 \n"
+
+test_string_array = testProgramOutput "10 A$(5)=\"HI\":?A$(1);A$(5)\n" "HI\n"
+
+test_arithmetic_expression = testProgramOutput "10 A=5:?A^2+3*A-1/2\n" " 39.5 \n"
+
+test_parentheses = testProgramOutput "10 A=5:?A^(2+3)*(A-1)/2\n" " 6250 \n"
+
+test_relational_operators_on_numbers = TestList $ [
+ "eq" ~: testProgramOutput "10 ?1= 1:?1= 2:?2= 1\n" "-1 \n 0 \n 0 \n",
+ "ne" ~: testProgramOutput "10 ?1<>1:?1<>2:?2<>1\n" " 0 \n-1 \n-1 \n",
+ "lt" ~: testProgramOutput "10 ?1< 1:?1< 2:?2< 1\n" " 0 \n-1 \n 0 \n",
+ "le" ~: testProgramOutput "10 ?1<=1:?1<=2:?2<=1\n" "-1 \n-1 \n 0 \n",
+ "gt" ~: testProgramOutput "10 ?1> 1:?1> 2:?2> 1\n" " 0 \n 0 \n-1 \n",
+ "ge" ~: testProgramOutput "10 ?1>=1:?1>=2:?2>=1\n" "-1 \n 0 \n-1 \n"
+ ]
+
+test_relational_operators_on_strings = TestList $ [
+ "eq" ~: testProgramOutput "10 ?\"A\"= \"A\":?\"A\"= \"B\":?\"B\"= \"A\"\n" "-1 \n 0 \n 0 \n",
+ "ne" ~: testProgramOutput "10 ?\"A\"<>\"A\":?\"A\"<>\"B\":?\"B\"<>\"A\"\n" " 0 \n-1 \n-1 \n",
+ "lt" ~: testProgramOutput "10 ?\"A\"< \"A\":?\"A\"< \"B\":?\"B\"< \"A\"\n" " 0 \n-1 \n 0 \n",
+ "le" ~: testProgramOutput "10 ?\"A\"<=\"A\":?\"A\"<=\"B\":?\"B\"<=\"A\"\n" "-1 \n-1 \n 0 \n",
+ "gt" ~: testProgramOutput "10 ?\"A\"> \"A\":?\"A\"> \"B\":?\"B\"> \"A\"\n" " 0 \n 0 \n-1 \n",
+ "ge" ~: testProgramOutput "10 ?\"A\">=\"A\":?\"A\">=\"B\":?\"B\">=\"A\"\n" "-1 \n 0 \n-1 \n"
+ ]
+
+test_boolean_logic = TestList $ [
+ "and" ~: testProgramOutput "10 ?0AND0:?0AND-1:?-1AND0:?-1AND-1\n" " 0 \n 0 \n 0 \n-1 \n",
+ "or" ~: testProgramOutput "10 ?0OR 0:?0OR -1:?-1OR 0:?-1OR -1\n" " 0 \n-1 \n-1 \n-1 \n",
+ "not" ~: testProgramOutput "10 ?NOT0:?NOT-1:?NOT2\n" "-1 \n 0 \n 0 \n"
+ ]
+
+test_boolean_logic_with_nonintegers = TestList $ [
+ "and" ~: testProgramOutput "10 ?0.1AND-0.1:?0.1AND0:?0AND0.1\n" " .1 \n 0 \n 0 \n",
+ "or" ~: testProgramOutput "10 ?0OR-0.1:?0.1OR0:?0OR0\n" "-.1 \n .1 \n 0 \n",
+ "not" ~: testProgramOutput "10 ?NOT-0.9:?NOT-0.1:?NOT0.1:?NOT0.9:?NOT1.1\n" " 0 \n 0 \n 0 \n 0 \n 0 \n"
+ ]
+
+test_negation = testProgramOutput "10 A=5:?-A:?-(-A)\n" "-5 \n 5 \n"
+
+test_abs = testExpressions [
+ ("ABS()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("ABS(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("ABS( 5.7)", " 5.7 "),
+ ("ABS( 0 )", " 0 "),
+ ("ABS(-5.7)", " 5.7 "),
+ ("ABS(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_asc = testExpressions [
+ ("ASC()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("ASC(65)", "!TYPE MISMATCH IN LINE 1"),
+ ("ASC(\"\")", "!INVALID ARGUMENT IN LINE 1"),
+ ("ASC(\"A\")", " 65 "),
+ ("ASC(\"ABC\")", " 65 "),
+ ("ASC(\"0\")", " 48 "),
+ ("ASC(\"0\",\"0\")", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_atn = testExpressions [
+ ("ATN()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("ATN(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("ATN(0)", " 0 " ),
+ ("ATN(1)", " .7853982 "),
+ ("ATN(10)", " 1.4711276 "),
+ ("ATN(-1)", "-.7853982 "),
+ ("ATN(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_chr = testExpressions [
+ ("CHR$()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("CHR$(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("CHR$(-1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("CHR$(10)", "\n"),
+ ("CHR$(13)", "\r"),
+ ("CHR$(32)", " "),
+ ("CHR$(48)", "0"),
+ ("CHR$(65)", "A"),
+ ("CHR$(256)", "!INVALID ARGUMENT IN LINE 1"),
+ ("CHR$(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_cos = testExpressions [
+ ("COS()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("COS(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("COS(0)", " 1 "),
+ ("COS(1)", " .5403023 "),
+ ("COS(1.5707964)", "-4.371139E-8 "),
+ ("COS(3.1415927)", "-1 "),
+ ("COS(4.712389)", " 1.1924881E-8 "),
+ ("COS(6.2831855)", " 1 "),
+ ("COS(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_exp = testExpressions [
+ ("EXP()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("EXP(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("EXP(-1)", " .36787945 "),
+ ("EXP(0)", " 1 "),
+ ("EXP(1)", " 2.7182817 "),
+ ("EXP(2)", " 7.389056 "),
+ ("EXP(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_int = testExpressions [
+ ("INT()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("INT(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("INT(-23.1)", "-24 "),
+ ("INT(23)", " 23 "),
+ ("INT(23.1)", " 23 "),
+ ("INT(23.9)", " 23 "),
+ ("INT(24)", " 24 "),
+ ("INT(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_left = testExpressions [
+ ("LEFT$()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("LEFT$(\"A\")", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("LEFT$(\"ABC\",\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("LEFT$(1,1)", "!TYPE MISMATCH IN LINE 1"),
+ ("LEFT$(\"ABC\",-1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("LEFT$(\"ABC\",-.1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("LEFT$(\"ABC\", 0)", ""),
+ ("LEFT$(\"ABC\", 1)", "A"),
+ ("LEFT$(\"ABC\", 2)", "AB"),
+ ("LEFT$(\"ABC\", 2.9)", "AB"),
+ ("LEFT$(\"ABC\", 3)", "ABC"),
+ ("LEFT$(\"ABC\", 4)", "ABC"),
+ ("LEFT$(\"A\",1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_len = testExpressions [
+ ("LEN()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("LEN(1)", "!TYPE MISMATCH IN LINE 1"),
+ ("LEN(\"\")", " 0 "),
+ ("LEN(\"A\")", " 1 "),
+ ("LEN(\" \" + CHR$(0) + \"23$!\")", " 6 "),
+ ("LEN(\"A\", \"B\")", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_log = testExpressions [
+ ("LOG()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("LOG(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("LOG(-1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("LOG( 0)", "!INVALID ARGUMENT IN LINE 1"),
+ ("LOG( 0.1)", "-2.3025851 "),
+ ("LOG( 1)", " 0 "),
+ ("LOG(2.7182817)", " .99999994 "),
+ ("LOG(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_mid = testExpressions [
+ ("MID$()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("MID$(\"ABC\")", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("MID$(1,1)", "!TYPE MISMATCH IN LINE 1"),
+ ("MID$(\"ABC\",\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("MID$(\"ABC\",-1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("MID$(\"ABC\", 0)", "!INVALID ARGUMENT IN LINE 1"),
+ ("MID$(\"ABC\", 1)", "ABC"),
+ ("MID$(\"ABC\", 2)", "BC"),
+ ("MID$(\"ABC\", 3)", "C"),
+ ("MID$(\"ABC\", 4)", ""),
+ ("MID$(1,1)", "!TYPE MISMATCH IN LINE 1"),
+ ("MID$(\"ABC\",\"A\",1)", "!TYPE MISMATCH IN LINE 1"),
+ ("MID$(\"ABC\",1,\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("MID$(\"ABC\",-1, 1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("MID$(\"ABC\", 0, 1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("MID$(\"ABC\", 0,-1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("MID$(\"ABC\", 1,0)", ""),
+ ("MID$(\"ABC\", 1,1)", "A"),
+ ("MID$(\"ABC\", 1,2)", "AB"),
+ ("MID$(\"ABC\", 1,3)", "ABC"),
+ ("MID$(\"ABC\", 1,4)", "ABC"),
+ ("MID$(\"ABC\", 2,0)", ""),
+ ("MID$(\"ABC\", 2,1)", "B"),
+ ("MID$(\"ABC\", 2,2)", "BC"),
+ ("MID$(\"ABC\", 2.9, 2.9)", "BC"),
+ ("MID$(\"ABC\", 2,3)", "BC"),
+ ("MID$(\"ABC\", 3,0)", ""),
+ ("MID$(\"ABC\", 3,1)", "C"),
+ ("MID$(\"ABC\", 3,2)", "C"),
+ ("MID$(\"ABC\", 4,0)", ""),
+ ("MID$(\"ABC\", 4,1)", ""),
+ ("MID$(\"ABC\", 1, 1, 1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_right = testExpressions [
+ ("RIGHT$()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("RIGHT$(\"A\")", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("RIGHT$(\"ABC\",\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("RIGHT$(1,1)", "!TYPE MISMATCH IN LINE 1"),
+ ("RIGHT$(\"ABC\",-1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("RIGHT$(\"ABC\", 0)", ""),
+ ("RIGHT$(\"ABC\", 1)", "C"),
+ ("RIGHT$(\"ABC\", 2)", "BC"),
+ ("RIGHT$(\"ABC\", 2.9)", "BC"),
+ ("RIGHT$(\"ABC\", 3)", "ABC"),
+ ("RIGHT$(\"ABC\", 4)", "ABC"),
+ ("RIGHT$(\"A\",1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_rnd = testProgramOutput
+ "1 ?RND(-1):?RND(1):?RND(1):?RND(0):?RND(10):?RND(-2.5)\n"
+ " .35925463 \n .3306234 \n .13648525 \n .13648525 \n .53864 \n .10321328 \n"
+
+test_rnd_errors = testExpressions [
+ ("RND()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("RND(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("RND(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+-- RANDOMIZE is difficult to test because it depends on system time
+
+test_sgn = testExpressions [
+ ("SGN()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("SGN(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("SGN( 5.7)", " 1 "),
+ ("SGN( 0 )", " 0 "),
+ ("SGN(-5.7)", "-1 "),
+ ("SGN(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_sin = testExpressions [
+ ("SIN()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("SIN(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("SIN(0)", " 0 "),
+ ("SIN(1)", " .84147096 "),
+ ("SIN(1.5707964)", " 1 "),
+ ("SIN(3.1415927)", "-8.742278E-8 "),
+ ("SIN(4.712389)", "-1 "),
+ ("SIN(6.2831855)", " 1.7484555E-7 "),
+ ("SIN(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_spc = testExpressions [
+ ("SPC()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("SPC(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("SPC(-1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("SPC(0)", ""),
+ ("SPC(1)", " "),
+ ("SPC(2.9)", " "),
+ ("SPC(10)", " "),
+ ("SPC(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_sqr = testExpressions [
+ ("SQR()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("SQR(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("SQR(-1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("SQR(0)", " 0 "),
+ ("SQR(2)", " 1.4142135 "),
+ ("SQR(4)", " 2 "),
+ ("SQR(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_str = testExpressions [
+ ("STR$()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("STR$(\"ABC\")", "!TYPE MISMATCH IN LINE 1"),
+ ("STR$(1E2)", " 100"),
+ ("STR$(.000000001)", " 1.E-9"),
+ ("STR$(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_tan = testExpressions [
+ ("TAN()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("TAN(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("TAN(0)", " 0 "),
+ ("TAN(.7853982)", " 1 "),
+ ("TAN(1)", " 1.5574077 "),
+ ("TAN(1.5707964)", "-22877332 "),
+ ("TAN(3.1415927)", " 8.742278E-8 "),
+ ("TAN(4.712389)", "-83858280 "),
+ ("TAN(6.2831855)", " 1.7484555E-7 "),
+ ("TAN(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_val = testExpressions [
+ ("VAL()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("VAL(1)", "!TYPE MISMATCH IN LINE 1"),
+ ("VAL(\"\")", " 0 "),
+ ("VAL(\"123\")", " 123 "),
+ ("VAL(\" 123 \")", " 123 "),
+ ("VAL(\" 1 2\")", " 1 "),
+ ("VAL(\"1A\")", " 1 "),
+ ("VAL(\"A\")", " 0 "),
+ ("VAL(\"1\",\"1\")", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_goto_forwards = testProgramOutput "10GOTO30\n20?20\n30?30\n" " 30 \n"
+
+test_goto_backwards = testProgramOutput "10GOTO50\n20?20\n30?30\n40END\n50GOTO30\n" " 30 \n"
+
+test_gosub = testProgramOutput "1?1\n2GOSUB5\n3?3\n4END\n5?5\n6RETURN\n" " 1 \n 5 \n 3 \n"
+
+test_nested_gosub = testProgramOutput (unlines [
+ " 1 ?1 ",
+ " 2 GOSUB5 ",
+ " 3 ?3 ",
+ " 4 END ",
+ " 5 ?5 ",
+ " 6 GOSUB9 ",
+ " 7 ?7 ",
+ " 8 RETURN ",
+ " 9 ?9 ",
+ " 10 RETURN "
+ ])
+ " 1 \n 5 \n 9 \n 7 \n 3 \n"
+
+test_return_does_double_duty = testProgramOutput (unlines [
+ "10 ?10:GOSUB30",
+ "20 ?20:END",
+ "30 ?30:GOSUB40",
+ "40 ?40:RETURN"
+ ])
+ " 10 \n 30 \n 40 \n 40 \n 20 \n"
+
+test_on_goto = TestList [
+ testProgramOutput "1 ON\"A\"GOTO2\n" "!TYPE MISMATCH IN LINE 1\n",
+ testProgramOutput "1 A=-1 :ONAGOTO3,4,5\n2 ?2\n3 ?3\n4 ?4\n5 ?5\n6 ?6\n" " 2 \n 3 \n 4 \n 5 \n 6 \n",
+ testProgramOutput "1 A=-0.1:ONAGOTO3,4,5\n2 ?2\n3 ?3\n4 ?4\n5 ?5\n6 ?6\n" " 2 \n 3 \n 4 \n 5 \n 6 \n",
+ testProgramOutput "1 A= 0 :ONAGOTO3,4,5\n2 ?2\n3 ?3\n4 ?4\n5 ?5\n6 ?6\n" " 2 \n 3 \n 4 \n 5 \n 6 \n",
+ testProgramOutput "1 A= 1 :ONAGOTO3,4,5\n2 ?2\n3 ?3\n4 ?4\n5 ?5\n6 ?6\n" " 3 \n 4 \n 5 \n 6 \n",
+ testProgramOutput "1 A= 2 :ONAGOTO3,4,5\n2 ?2\n3 ?3\n4 ?4\n5 ?5\n6 ?6\n" " 4 \n 5 \n 6 \n",
+ testProgramOutput "1 A= 2.9:ONAGOTO3,4,5\n2 ?2\n3 ?3\n4 ?4\n5 ?5\n6 ?6\n" " 4 \n 5 \n 6 \n",
+ testProgramOutput "1 A= 3 :ONAGOTO3,4,5\n2 ?2\n3 ?3\n4 ?4\n5 ?5\n6 ?6\n" " 5 \n 6 \n",
+ testProgramOutput "1 A= 4 :ONAGOTO3,4,5\n2 ?2\n3 ?3\n4 ?4\n5 ?5\n6 ?6\n" " 2 \n 3 \n 4 \n 5 \n 6 \n",
+ testProgramOutput "1 A= 2 :ONAGOTO3,5,4\n2 ?2\n3 ?3\n4 ?4\n5 ?5\n6 ?6\n" " 5 \n 6 \n"
+ ]
+
+test_on_gosub = TestList [
+ testProgramOutput "1 ON\"A\"GOSUB2\n" "!TYPE MISMATCH IN LINE 1\n",
+ testProgramOutput "1 A=-1 :ONAGOSUB3,4,5:END\n2 ?2:RETURN\n3 ?3:RETURN\n4 ?4:RETURN\n5 ?5:RETURN\n6 ?6:RETURN\n" "",
+ testProgramOutput "1 A=-0.1:ONAGOSUB3,4,5:END\n2 ?2:RETURN\n3 ?3:RETURN\n4 ?4:RETURN\n5 ?5:RETURN\n6 ?6:RETURN\n" "",
+ testProgramOutput "1 A= 0 :ONAGOSUB3,4,5:END\n2 ?2:RETURN\n3 ?3:RETURN\n4 ?4:RETURN\n5 ?5:RETURN\n6 ?6:RETURN\n" "",
+ testProgramOutput "1 A= 1 :ONAGOSUB3,4,5:END\n2 ?2:RETURN\n3 ?3:RETURN\n4 ?4:RETURN\n5 ?5:RETURN\n6 ?6:RETURN\n" " 3 \n",
+ testProgramOutput "1 A= 2 :ONAGOSUB3,4,5:END\n2 ?2:RETURN\n3 ?3:RETURN\n4 ?4:RETURN\n5 ?5:RETURN\n6 ?6:RETURN\n" " 4 \n",
+ testProgramOutput "1 A= 2.9:ONAGOSUB3,4,5:END\n2 ?2:RETURN\n3 ?3:RETURN\n4 ?4:RETURN\n5 ?5:RETURN\n6 ?6:RETURN\n" " 4 \n",
+ testProgramOutput "1 A= 3 :ONAGOSUB3,4,5:END\n2 ?2:RETURN\n3 ?3:RETURN\n4 ?4:RETURN\n5 ?5:RETURN\n6 ?6:RETURN\n" " 5 \n",
+ testProgramOutput "1 A= 4 :ONAGOSUB3,4,5:END\n2 ?2:RETURN\n3 ?3:RETURN\n4 ?4:RETURN\n5 ?5:RETURN\n6 ?6:RETURN\n" "",
+ testProgramOutput "1 A= 2 :ONAGOSUB3,5,4:END\n2 ?2:RETURN\n3 ?3:RETURN\n4 ?4:RETURN\n5 ?5:RETURN\n6 ?6:RETURN\n" " 5 \n"
+ ]
+
+test_if = TestList [
+ testProgramOutput "1 IF\"A\"THEN?1\n" "!TYPE MISMATCH IN LINE 1\n",
+ testProgramOutput "1 IF-11THEN?1:?2\n2 ?3\n" " 1 \n 2 \n 3 \n",
+ testProgramOutput "1 IF 0THEN?1:?2\n2 ?3\n" " 3 \n",
+ testProgramOutput "1 IF 1THEN?1:?2\n2 ?3\n" " 1 \n 2 \n 3 \n",
+ testProgramOutput "1 IF .1THEN?1:?2\n2 ?3\n" " 1 \n 2 \n 3 \n",
+ testProgramOutput "1 IF -.1THEN?1:?2\n2 ?3\n" " 1 \n 2 \n 3 \n",
+ testProgramOutput "1 IF 2.1THEN?1:?2\n2 ?3\n" " 1 \n 2 \n 3 \n"
+ ]
+
+test_for = TestList [
+ testProgramOutput "1 FORA$=1TO10\n" "!TYPE MISMATCH IN LINE 1\n",
+ testProgramOutput "1 FORA%=1TO10\n" "!TYPE MISMATCH IN LINE 1\n",
+ testProgramOutput "1 FORA=\"A\"TO3\n" "!TYPE MISMATCH IN LINE 1\n",
+ testProgramOutput "1 FORA=1TO\"A\"\n" "!TYPE MISMATCH IN LINE 1\n",
+ testProgramOutput "1 FORA=1TO3:?A:NEXT:?99:?A\n" " 1 \n 2 \n 3 \n 99 \n 4 \n",
+ testProgramOutput "1 FORA=2TO8STEP2:?A:NEXT:?99:?A\n" " 2 \n 4 \n 6 \n 8 \n 99 \n 10 \n",
+ testProgramOutput "1 FORA=8TO2STEP-2:?A:NEXT:?99:?A\n" " 8 \n 6 \n 4 \n 2 \n 99 \n 0 \n",
+ testProgramOutput "1 FORA=1TO0:?A:NEXT:?99:?A\n" " 1 \n 99 \n 2 \n",
+ testProgramOutput "1 FORA=1TO3\n2 ?A\n3 NEXT\n" " 1 \n 2 \n 3 \n",
+ testProgramOutput "1 FORA=1TO3\n2 ?A\n3 NEXTA\n" " 1 \n 2 \n 3 \n",
+ testProgramOutput "1 FORA=1TO3\n2 ?A\n3 NEXTB\n" " 1 \n!NEXT WITHOUT FOR ERROR (VAR B) IN LINE 3\n"
+ ]
+
+test_nested_for = testProgramOutput (unlines [
+ "1 FORA=10TO20STEP10",
+ "2 FORB=1TO3",
+ "3 ?A+B",
+ "4 NEXT",
+ "5 NEXT"
+ ])
+ " 11 \n 12 \n 13 \n 21 \n 22 \n 23 \n"
+
+test_improperly_nested_for = testProgramOutput (unlines [
+ "1 FORA=10TO20STEP10",
+ "2 FORB=1TO3",
+ "3 ?A+B",
+ "4 NEXTA",
+ "5 NEXTB"
+ ])
+ " 11 \n 21 \n 32 \n!NEXT WITHOUT FOR ERROR (VAR A) IN LINE 4\n"
+
+test_return_in_for = testProgramOutput (unlines [
+ "10 GOSUB40",
+ "20 NEXT",
+ "30 END",
+ "40 FORI=1TO3",
+ "50 PRINT\"HELLO\"",
+ "60 RETURN"
+ ])
+ "HELLO\nHELLO\n!RETURN WITHOUT GOSUB ERROR IN LINE 60\n"
+
+test_print_literals = testProgramOutput "10 PRINT\"NUMBER\";5;\"AND\";-2\n" "NUMBER 5 AND-2 \n"
+
+test_float_representation = testProgramOutput "10 ?1E17:?5.55555\n" " 1.E+17 \n 5.55555 \n"
+
+test_tab = testProgramOutput
+ "10 ?TAB(4);\"A\";TAB(10);\"B\";TAB(11);\"C\";TAB(4);\"D\"\n"
+ " A BCD\n"
+
+test_tab_with_nonintegers = testProgramOutput "10 ?TAB(2.9);\"A\"\n" " A\n"
+
+test_tab_with_newlines_and_linefeeds = testProgramOutput
+ "10 ?\"HI\";CHR$(13);\"TO\";TAB(5);\"YOU\";CHR$(10);\"AND\";TAB(10);\"ME\"\n"
+ "HI\rTO YOU\nAND ME\n"
+
+test_tab_wrongargs = testExpressions [
+ ("TAB()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"),
+ ("TAB(\"A\")", "!TYPE MISMATCH IN LINE 1"),
+ ("TAB(-1)", "!INVALID ARGUMENT IN LINE 1"),
+ ("TAB(1,1)", "!WRONG NUMBER OF ARGUMENTS IN LINE 1")
+ ]
+
+test_print_zones = testProgramOutput
+ "1 ?\"A\",\"B\",,\"C\":?\"123456789012345\",\"X\":?1,;:?2,:?,3\n"
+ "A B C\n123456789012345 X\n 1 2 3 \n"
+
+test_input = TestList [
+ "multiple values and types" ~: testProgramOutputWithInput
+ "1 INPUT\"WHAT\";A$,B,CD$(9),M%\n2 ?:?A$:?B:?CD$(9):?M%\n"
+ " Bob 4 , 3 ,2 1, 5.2\n"
+ "WHAT? \nBob 4\n 3 \n2 1\n 5 \n",
+ "trims whitespace" ~: testProgramOutputWithInput
+ "1 INPUTA$:?:?A$\n"
+ " \t Bob 4 \n"
+ "? \nBob 4\n",
+ "quoted strings" ~: testProgramOutputWithInput
+ "1 INPUTA$\n2 ?:?A$\n"
+ " \t\" Bob 4 \" \t \n"
+ "? \n Bob 4 \n",
+ "re-prompts for invalid number" ~: testProgramOutputWithInput
+ "1 INPUTA:?:?A\n"
+ "X\n4\n"
+ "? !NUMBER EXPECTED - RETRY INPUT LINE\n? \n 4 \n",
+ "re-prompts if not enough data on line" ~: testProgramOutputWithInput
+ "1 INPUT\"NUM\";A,B:?:?A:?B\n"
+ "3\n4\n"
+ "NUM? ?? \n 3 \n 4 \n",
+ "extra input ignored" ~: testProgramOutputWithInput
+ "1 INPUTA\n"
+ "1,2\n"
+ "? !EXTRA INPUT IGNORED\n",
+ "error if we reach eof without enough data" ~: testProgramOutputWithInput
+ "1 INPUTA,B:?:?A:?B\n"
+ "4\n"
+ "? ?? !END OF INPUT IN LINE 1\n",
+ "error if we reach eof without enough data (no newline)" ~: testProgramOutputWithInput
+ "1 INPUTA:?:?A\n"
+ ""
+ "? !END OF INPUT IN LINE 1\n"
+ ]
+
+test_read_data = TestList [
+ "multiple values and types" ~: testProgramOutput
+ "1 READ A$,B,CD$(9),M%\n2 ?A$:?B:?CD$(9):?M%\n3 DATA Bob 4 , 3 ,2 1, 5.2\n"
+ "Bob 4\n 3 \n2 1\n 5 \n",
+ "trims whitespace" ~: testProgramOutput
+ "1 READA$:?A$\n2 DATA \t Bob 4 \n"
+ "Bob 4\n",
+ "quoted strings" ~: testProgramOutput
+ "1 READA$\n2 ?A$\n3 DATA \t\" Bob 4 \" \t \n"
+ " Bob 4 \n",
+ "type mismatch for invalid number" ~: testProgramOutput
+ "1 READA:?:?A\n2 DATAX\n"
+ "!TYPE MISMATCH IN LINE 1\n",
+ "data on multiple lines" ~: testProgramOutput
+ "1 READA,B:?A:?B\n2 DATA3\n3 DATA4\n"
+ " 3 \n 4 \n",
+ "extra data ignored" ~: testProgramOutput
+ "1 READA:?A\n2 DATA1,2\n"
+ " 1 \n",
+ "error if we reach eof without enough data" ~: testProgramOutput
+ "1 READA,B:?A:?B\n2 DATA4\n"
+ "!OUT OF DATA IN LINE 1\n",
+ "don't care where data appears" ~: testProgramOutput
+ (unlines [
+ "1 DATA A:?7",
+ "2 READA$,B$,C:DATAmore",
+ "3 DATA 5",
+ "4 ?A$:?B$:?C"
+ ])
+ "A:?7\nmore\n 5 \n"
+ ]
+
+test_restore = testProgramOutput
+ (unlines [
+ "1 READ A,B,C:RESTORE 3:READ D,E:RESTORE:READ F,G,H:?A:?B:?C:?D:?E:?F:?G:?H\n",
+ "2 DATA1",
+ "3 DATA2",
+ "4 DATA3"
+ ])
+ " 1 \n 2 \n 3 \n 2 \n 3 \n 1 \n 2 \n 3 \n"
+
+test_def_fn = TestList [
+ "simple float" ~: testProgramOutput
+ "1 DEFFNA(X)=X^2+1:?FNA(4)\n"
+ " 17 \n",
+ "multi-arg float" ~: testProgramOutput
+ "1 DEFFNA(X,Y,Z$)=LEN(Z$)^2+2*X+Y:?FNA(2,3,\"HELLO\")\n"
+ " 32 \n",
+ "multi-arg string" ~: testProgramOutput
+ "1 DEFFNA$(X$,Y,Z)=MID$(X$,Y-1,Z+1):?FNA$(\"MAGILLICUDDY\",3,4)\n"
+ "AGILL\n",
+ "wrong num args" ~: testProgramOutput
+ "1 DEFFNA(X)=X*2:?FNA()\n"
+ "!WRONG NUMBER OF ARGUMENTS IN LINE 1\n",
+ "type mismatch" ~: testProgramOutput
+ "1 DEFFNA(X)=X*2:?A(\"X\")\n"
+ "!TYPE MISMATCH IN LINE 1\n",
+ "undefined" ~: testProgramOutput
+ "1 ?FNA(5):DEFFNA(X)=X*2\n"
+ "!UNDEFINED FUNCTION A IN LINE 1\n"
+ ]
+
+test_stop = testProgramOutput "1 ?1:STOP:?2\n" " 1 \n"
+
+test_rem = testProgramOutput "1 ?1:REM COMMENT:?2\n2 ?3\n" " 1 \n 3 \n"
diff --git a/test/Language/VintageBasic/LineScanner_test.hs b/test/Language/VintageBasic/LineScanner_test.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/VintageBasic/LineScanner_test.hs
@@ -0,0 +1,33 @@
+module Language.VintageBasic.LineScanner_test where
+
+import Test.HUnit
+import Language.VintageBasic.Asserts
+import Language.VintageBasic.LineScanner
+import Language.VintageBasic.Result
+
+assertRawParseResult = assertParseResult withLineAndCol ScanError rawLinesP
+assertRawParseError = assertParseError withLineAndCol ScanError rawLinesP
+
+test_LineScanner = TestCase $ do
+ let text = unlines ["10SKDJF@#"," 5 ASJDKFdf "]
+ assertRawParseResult text [(10, 3, "SKDJF@#"), (5, 6, "ASJDKFdf ")]
+
+test_reports_error_if_line_doesn't_start_with_number = TestCase $ do
+ let text = unlines ["10SKDJF@#","ASJD4KFdf "]
+ assertRawParseError text "EXPECTING LINE NUMBER OR END OF FILE"
+
+test_skips_blank_lines = TestCase $ do
+ let text = unlines ["","10?","","20?",""]
+ assertRawParseResult text [(10, 3, "?"), (20, 3, "?")]
+
+test_reports_error_if_file_doesn't_end_in_newline = TestCase $ do
+ let text = "10SKDJF@#"
+ assertRawParseError text "UNEXPECTED END OF FILE\n EXPECTING END OF LINE OR CHARACTER"
+
+test_accepts_blank_line = TestCase $ do
+ let text = unlines ["10"]
+ assertRawParseResult text [(10, 3, "")]
+
+test_strips_carriage_return_preceding_newline = TestCase $ do
+ let text = "10 BLAH\r\n20 BLORT\r\n"
+ assertRawParseResult text [(10, 4, "BLAH"), (20, 4, "BLORT")]
diff --git a/test/Language/VintageBasic/Parser_test.hs b/test/Language/VintageBasic/Parser_test.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/VintageBasic/Parser_test.hs
@@ -0,0 +1,215 @@
+module Language.VintageBasic.Parser_test where
+
+import Test.HUnit
+import Text.ParserCombinators.Parsec(parse)
+import Text.ParserCombinators.Parsec.Pos
+import Language.VintageBasic.Asserts
+import Language.VintageBasic.Builtins
+import Language.VintageBasic.LexCommon(Tagged(..))
+import Language.VintageBasic.Parser
+import Language.VintageBasic.Result
+import Language.VintageBasic.Syntax
+import Language.VintageBasic.Tokenizer(taggedTokensP)
+
+tokenize source = let (Right taggedToks) = parse taggedTokensP "" source in taggedToks
+
+goodStatements source expectedColAndStatements = TestCase $
+ assertParseResult withCol SyntaxError statementListP (tokenize source) expectedColAndStatements
+
+badStatements parser source expectedError = TestCase $
+ assertParseError withCol SyntaxError statementListP (tokenize source) expectedError
+
+goodExpr source expectedExpr = TestCase $
+ assertParseResult id SyntaxError exprP (tokenize source) expectedExpr
+
+badExpr source expectedError = TestCase $
+ assertParseError id SyntaxError exprP (tokenize source) expectedError
+
+test_parses_multiple_statements = goodStatements
+ ":?::?: "
+ [(2,PrintS []), (5,PrintS [])]
+
+test_parse_bare_print = goodStatements
+ "PRINT"
+ [(1,PrintS [])]
+
+test_parse_print_string = goodStatements
+ "PRINT\"hello\""
+ [(1,PrintS [LitX (StringLit "hello")])]
+
+test_parse_print_string_ending_in_semicolon = goodStatements
+ "PRINT\"hello\";"
+ [(1,PrintS [LitX (StringLit "hello"), EmptySeparatorX])]
+
+test_parse_print_string_ending_in_comma = goodStatements
+ "PRINT\"hello\","
+ [(1,PrintS [LitX (StringLit "hello"), NextZoneX])]
+
+test_parse_print_with_semicolon_separated_parts = goodStatements
+ "PRINT\"hello\";\"there\""
+ [(1,PrintS [LitX (StringLit "hello"), EmptySeparatorX, LitX (StringLit "there")])]
+
+test_parse_print_with_juxtaposed_parts = goodStatements
+ "PRINT\"hello\"\"there\""
+ [(1,PrintS [LitX (StringLit "hello"), LitX (StringLit "there")])]
+
+test_parse_print_with_comma_separated_parts = goodStatements
+ "PRINT\"hello\",\"there\""
+ [(1,PrintS [LitX (StringLit "hello"), NextZoneX, LitX (StringLit "there")])]
+
+test_parse_print_with_a_comma_at_the_start = goodStatements
+ "PRINT,\"hello\""
+ [(1,PrintS [NextZoneX, LitX (StringLit "hello")])]
+
+test_parse_let = goodStatements
+ "LETA=1"
+ [(1,LetS (ScalarVar (VarName FloatType "A")) (LitX (FloatLit 1.0)))]
+
+test_parse_let_wo_keyword = goodStatements
+ "A=1"
+ [(1,LetS (ScalarVar (VarName FloatType "A")) (LitX (FloatLit 1.0)))]
+
+test_parse_multiple_dims = goodStatements
+ "DIMA$(5),G(14,20)"
+ [(1,DimS [(VarName StringType "A", [(LitX (FloatLit 5))]), (VarName FloatType "G", [(LitX (FloatLit 14)), (LitX (FloatLit 20))])])]
+
+test_parse_goto = goodStatements
+ "GOTO20"
+ [(1,GotoS 20)]
+
+test_ignores_space_after_target = goodStatements
+ "GOTO20 "
+ [(1,GotoS 20)]
+
+test_parse_gosub = goodStatements
+ "GOSUB20"
+ [(1,GosubS 20)]
+
+test_parse_on_goto = goodStatements
+ "ON3GOTO10,20,40"
+ [(1,OnGotoS (LitX (FloatLit 3)) [10,20,40])]
+
+test_parse_on_gosub = goodStatements
+ "ON3GOSUB10,20,40"
+ [(1,OnGosubS (LitX (FloatLit 3)) [10,20,40])]
+
+test_parse_data = goodStatements
+ "DATA4,5,\"THIS,WORKS\""
+ [(1,DataS "4,5,\"THIS,WORKS\"")]
+
+test_parse_read = goodStatements
+ "READA$(5),B"
+ [(1,ReadS [ArrVar (VarName StringType "A") [(LitX (FloatLit 5))], ScalarVar (VarName FloatType "B")])]
+
+test_parse_restore = goodStatements
+ "RESTORE"
+ [(1,RestoreS Nothing)]
+
+test_parse_restore_with_line_number = goodStatements
+ "RESTORE20"
+ [(1,RestoreS (Just 20))]
+
+test_parse_def_fn = goodStatements
+ "DEFFNAN1$(B,CD$)=4+B"
+ [(1,DefFnS (VarName StringType "AN1") [(VarName FloatType "B"), (VarName StringType "CD")] (BinX AddOp (LitX (FloatLit 4)) (VarX (ScalarVar (VarName FloatType "B")))))]
+
+test_parse_fn = goodStatements
+ "?FNAN2$(1,\"X\")"
+ [(1,PrintS [FnX (VarName StringType "AN2") [(LitX (FloatLit 1)), (LitX (StringLit "X"))]])]
+
+test_parse_end = goodStatements
+ "END"
+ [(1,EndS)]
+
+test_parse_stop = goodStatements
+ "STOP"
+ [(1,StopS)]
+
+fl v = LitX (FloatLit v)
+sl s = LitX (StringLit s)
+fv s = VarX (ScalarVar (VarName FloatType s))
+iv s = VarX (ScalarVar (VarName IntType s))
+sv s = VarX (ScalarVar (VarName StringType s))
+
+test_primitive_expressions = TestList [
+ "round number" ~: goodExpr "234" (fl 234),
+ "float" ~: goodExpr "2.3" (fl 2.3),
+ "string" ~: goodExpr "\"Work\"" (sl "Work"),
+ "builtin" ~: goodExpr "SIN(1)" (BuiltinX SinBI [(fl 1)]),
+ "builtin2" ~: goodExpr "LEFT$(A$,1)" (BuiltinX LeftBI [sv "A", fl 1]),
+ "fn" ~: goodExpr "FNAB(1,2,3)" (FnX (VarName FloatType "AB") [fl 1, fl 2, fl 3]),
+ "float var" ~: goodExpr "BR" (fv "BR"),
+ "int var" ~: goodExpr "BR%" (iv "BR"),
+ "string var" ~: goodExpr "BR$" (sv "BR"),
+ "array var" ~: goodExpr "AB(20, 5)" (VarX (ArrVar (VarName FloatType "AB") [fl 20, fl 5]))
+ ]
+
+test_operators = TestList [
+ "unary +" ~: goodExpr "+A" (fv "A"),
+ "unary -" ~: goodExpr "-A" (MinusX (fv "A")),
+ "num add" ~: goodExpr "1+2" (BinX AddOp (fl 1) (fl 2)),
+ "num sub" ~: goodExpr "1-2" (BinX SubOp (fl 1) (fl 2)),
+ "num mul" ~: goodExpr "1*2" (BinX MulOp (fl 1) (fl 2)),
+ "num div" ~: goodExpr "1/2" (BinX DivOp (fl 1) (fl 2)),
+ "num pow" ~: goodExpr "1^2" (BinX PowOp (fl 1) (fl 2)),
+ "num eq" ~: goodExpr "1=2" (BinX EqOp (fl 1) (fl 2)),
+ "num ne" ~: goodExpr "1<>2" (BinX NEOp (fl 1) (fl 2)),
+ "num lt" ~: goodExpr "1<2" (BinX LTOp (fl 1) (fl 2)),
+ "num gt" ~: goodExpr "1>2" (BinX GTOp (fl 1) (fl 2)),
+ "string concat" ~: goodExpr "\"A\"+\"B\"" (BinX AddOp (sl "A") (sl "B")),
+ "string lt" ~: goodExpr "\"A\"<\"B\"" (BinX LTOp (sl "A") (sl "B")),
+ "string gt" ~: goodExpr "\"A\">\"B\"" (BinX GTOp (sl "A") (sl "B")),
+ "string eq" ~: goodExpr "\"A\"=\"B\"" (BinX EqOp (sl "A") (sl "B")),
+ "and" ~: goodExpr "1=2AND3=4" (BinX AndOp (BinX EqOp (fl 1) (fl 2)) (BinX EqOp (fl 3) (fl 4))),
+ "or" ~: goodExpr "1=2OR3=4" (BinX OrOp (BinX EqOp (fl 1) (fl 2)) (BinX EqOp (fl 3) (fl 4))),
+ "not" ~: goodExpr "NOT1" (NotX (fl 1))
+ ]
+
+test_associativity = TestList [
+ "or assoc" ~: goodExpr "1OR2OR3" (BinX OrOp (BinX OrOp (fl 1) (fl 2)) (fl 3)),
+ "and assoc" ~: goodExpr "1AND2AND3" (BinX AndOp (BinX AndOp (fl 1) (fl 2)) (fl 3)),
+ "eq assoc" ~: goodExpr "1=2=3" (BinX EqOp (BinX EqOp (fl 1) (fl 2)) (fl 3)),
+ "ne assoc" ~: goodExpr "1<>2<>3" (BinX NEOp (BinX NEOp (fl 1) (fl 2)) (fl 3)),
+ "lt assoc" ~: goodExpr "1<2<3" (BinX LTOp (BinX LTOp (fl 1) (fl 2)) (fl 3)),
+ "le assoc" ~: goodExpr "1<=2<=3" (BinX LEOp (BinX LEOp (fl 1) (fl 2)) (fl 3)),
+ "gt assoc" ~: goodExpr "1>2>3" (BinX GTOp (BinX GTOp (fl 1) (fl 2)) (fl 3)),
+ "ge assoc" ~: goodExpr "1>=2>=3" (BinX GEOp (BinX GEOp (fl 1) (fl 2)) (fl 3)),
+ "add assoc" ~: goodExpr "1+2+3" (BinX AddOp (BinX AddOp (fl 1) (fl 2)) (fl 3)),
+ "sub assoc" ~: goodExpr "1-2-3" (BinX SubOp (BinX SubOp (fl 1) (fl 2)) (fl 3)),
+ "mul assoc" ~: goodExpr "1*2*3" (BinX MulOp (BinX MulOp (fl 1) (fl 2)) (fl 3)),
+ "div assoc" ~: goodExpr "1/2/3" (BinX DivOp (BinX DivOp (fl 1) (fl 2)) (fl 3)),
+ "pow assoc" ~: goodExpr "1^2^3" (BinX PowOp (fl 1) (BinX PowOp (fl 2) (fl 3)))
+ ]
+
+test_precedence = TestList [
+ "and beats or" ~: goodExpr "1OR2AND3" (BinX OrOp (fl 1) (BinX AndOp (fl 2) (fl 3))),
+ "not beats and" ~: goodExpr "NOT1AND2" (BinX AndOp (NotX (fl 1)) (fl 2)),
+ "eq beats not" ~: goodExpr "NOT1=2" (NotX (BinX EqOp (fl 1) (fl 2))),
+ "eq class" ~: goodExpr "1=2<>3<4<=5>6>=7" (BinX GEOp (BinX GTOp (BinX LEOp (BinX LTOp (BinX NEOp (BinX EqOp (fl 1) (fl 2)) (fl 3)) (fl 4)) (fl 5)) (fl 6)) (fl 7)),
+ "eq class rev" ~: goodExpr "1>=2>3<=4<5<>6=7" (BinX EqOp (BinX NEOp (BinX LTOp (BinX LEOp (BinX GTOp (BinX GEOp (fl 1) (fl 2)) (fl 3)) (fl 4)) (fl 5)) (fl 6)) (fl 7)),
+ "add beats eq" ~: goodExpr "1=2+3" (BinX EqOp (fl 1) (BinX AddOp (fl 2) (fl 3))),
+ "add class" ~: goodExpr "1+2-3" (BinX SubOp (BinX AddOp (fl 1) (fl 2)) (fl 3)),
+ "add class rev" ~: goodExpr "1-2+3" (BinX AddOp (BinX SubOp (fl 1) (fl 2)) (fl 3)),
+ "mul beats add" ~: goodExpr "1+2*3" (BinX AddOp (fl 1) (BinX MulOp (fl 2) (fl 3))),
+ "mul class" ~: goodExpr "1*2/3" (BinX DivOp (BinX MulOp (fl 1) (fl 2)) (fl 3)),
+ "mul class rev" ~: goodExpr "1/2*3" (BinX MulOp (BinX DivOp (fl 1) (fl 2)) (fl 3)),
+ "pow beats mul" ~: goodExpr "1*2^3" (BinX MulOp (fl 1) (BinX PowOp (fl 2) (fl 3))),
+ "unary - beats pow" ~: goodExpr "-A^B" (BinX PowOp (MinusX (fv "A")) (fv "B"))
+ ]
+
+test_parentheses = TestList [
+ goodExpr "(1+2)*3" (BinX MulOp (ParenX (BinX AddOp (fl 1) (fl 2))) (fl 3)),
+ goodExpr "-(1+2)*3" (BinX MulOp (MinusX (ParenX (BinX AddOp (fl 1) (fl 2)))) (fl 3)),
+ goodExpr "(1+(2-3))*4" (BinX MulOp (ParenX (BinX AddOp (fl 1) (ParenX (BinX SubOp (fl 2) (fl 3))))) (fl 4))
+ ]
+
+test_embedded_spaces_are_ignored = TestList [
+ goodExpr "1 * 2 +3- 4" (BinX SubOp (BinX AddOp (BinX MulOp (fl 1) (fl 2)) (fl 3)) (fl 4)),
+ goodExpr "CHR$ ( A ) " (BuiltinX ChrBI [fv "A"])
+ ]
+
+test_bad_expressions = TestList [
+ "starting with operator" ~: badExpr "/4" "UNEXPECTED /",
+ "ending with operator" ~: badExpr "4/" "UNEXPECTED END OF LINE",
+ "double operator" ~: badExpr "4/*4" "UNEXPECTED *"
+ ]
diff --git a/test/Language/VintageBasic/Printer_test.hs b/test/Language/VintageBasic/Printer_test.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/VintageBasic/Printer_test.hs
@@ -0,0 +1,27 @@
+module Language.VintageBasic.Printer_test where
+
+import Test.HUnit
+import Language.VintageBasic.Printer
+
+floatTest (x, s) = TestCase $ assertEqual "" s (printFloat x)
+
+test_printFloat = TestList $ map floatTest [
+ ( -1.337e-20, "-1.337E-20" ),
+ ( -1, "-1" ),
+ ( 0, " 0" ),
+ ( 0.00000001, " .00000001" ),
+ ( 0.000000001, " 1.E-9" ),
+ ( 0.011111111, " 1.1111111E-2"),
+ ( 1, " 1" ),
+ ( 1.1, " 1.1" ),
+ ( 1.1111111, " 1.111111" ),
+ ( pi, " 3.1415927" ),
+ ( 9, " 9" ),
+ ( 1e2, " 100" ),
+ ( 1111.1111, " 1111.1111" ),
+ ( 16777215, " 16777215" ),
+ ( 55555555, " 55555556" ),
+ (100000000, " 1.E+8" ),
+ (444444444, " 4.4444445E+8"),
+ (555555555, " 5.555556E+8" )
+ ]
diff --git a/test/Language/VintageBasic/RuntimeParser_test.hs b/test/Language/VintageBasic/RuntimeParser_test.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/VintageBasic/RuntimeParser_test.hs
@@ -0,0 +1,33 @@
+module Language.VintageBasic.RuntimeParser_test where
+
+import Test.HUnit
+import Text.ParserCombinators.Parsec
+import Language.VintageBasic.RuntimeParser(dataValsP,readFloat)
+
+floatTest string expected = assertEqual "" expected (readFloat string)
+
+test_readFloat = TestCase $
+ mapM_ (uncurry floatTest) [
+ ("A", Nothing ),
+ (".", Just 0.0 ),
+ ("0", Just 0.0 ),
+ ("1", Just 1.0 ),
+ (" 1", Nothing ),
+ ("-1", Just (-1.0)),
+ ("+1", Just 1.0 ),
+ ("1.", Just 1.0 ),
+ ("-1.", Just (-1.0)),
+ (".1", Just 0.1 ),
+ ("-.1", Just (-0.1)),
+ ("1.0", Just 1.0 ),
+ ("1E", Nothing ),
+ ("1E.2", Nothing ),
+ ("1A", Just 1.0 ),
+ ("1 E2", Just 1.0 ),
+ ("1 2", Just 1.0 ),
+ ("1E2", Just 1.0E+2 ),
+ ("1E+2", Just 1.0E+2 ),
+ ("1E-2", Just 1.0E-2 ),
+ ("-1E-2", Just (-1.0E-2)),
+ ("123456789", Just 123456789.0)
+ ]
diff --git a/test/Language/VintageBasic/Tokenizer_test.hs b/test/Language/VintageBasic/Tokenizer_test.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/VintageBasic/Tokenizer_test.hs
@@ -0,0 +1,77 @@
+module Language.VintageBasic.Tokenizer_test where
+
+import Test.HUnit
+import Language.VintageBasic.Asserts
+import Language.VintageBasic.Builtins(Builtin(..))
+import Language.VintageBasic.Result
+import Language.VintageBasic.LineScanner
+import Language.VintageBasic.Tokenizer(Token(..),taggedTokensP,printToken)
+
+assertTokenizerResult = assertParseResult withCol SyntaxError taggedTokensP
+assertTokenizerError = assertParseError withCol SyntaxError taggedTokensP
+
+test_taggedTokensP = TestCase $ do
+ let source = [
+ ",:;()$%=<><=>=><+-*/^.?",
+ "ABSASCCHR$COSEXPINTLEFT$LENLOGMID$RIGHT$RNDSGNSINSPCSQRSTR$TABTANVAL",
+ "ANDORNOTLETDIMONGOSUBRETURNIFTHENFORTOSTEPNEXTPRINTINPUT",
+ "RANDOMIZEREADRESTOREDEFFNENDSTOP",
+ "\"hello\"REMGOFORTH\"ANDREAD\"",
+ "XDATATODATA"
+ ]
+ let expectedLenAndTokss = [
+ [(1,CommaTok), (1,ColonTok), (1,SemiTok), (1,LParenTok), (1,RParenTok),
+ (1,DollarTok), (1,PercentTok), (1,EqTok), (2,NETok), (2,LETok), (2,GETok),
+ (1,GTTok), (1,LTTok), (1,PlusTok), (1,MinusTok), (1,MulTok), (1,DivTok),
+ (1,PowTok), (1,DotTok), (1,PrintTok)],
+ [(3,BuiltinTok AbsBI), (3,BuiltinTok AscBI), (4,BuiltinTok ChrBI),
+ (3,BuiltinTok CosBI), (3,BuiltinTok ExpBI), (3,BuiltinTok IntBI),
+ (5,BuiltinTok LeftBI), (3,BuiltinTok LenBI), (3,BuiltinTok LogBI),
+ (4,BuiltinTok MidBI), (6,BuiltinTok RightBI), (3,BuiltinTok RndBI),
+ (3,BuiltinTok SgnBI), (3,BuiltinTok SinBI), (3,BuiltinTok SpcBI),
+ (3,BuiltinTok SqrBI), (4,BuiltinTok StrBI), (3,BuiltinTok TabBI),
+ (3,BuiltinTok TanBI), (3,BuiltinTok ValBI)],
+ [(3,AndTok), (2,OrTok), (3,NotTok), (3,LetTok), (3,DimTok), (2,OnTok),
+ (2,GoTok), (3,SubTok), (6,ReturnTok), (2,IfTok), (4,ThenTok), (3,ForTok),
+ (2,ToTok), (4,StepTok), (4,NextTok), (5,PrintTok), (5,InputTok)],
+ [(9,RandomizeTok), (4,ReadTok), (7,RestoreTok), (3,DefTok), (2,FnTok),
+ (3,EndTok), (4,StopTok)],
+ [(7,StringTok "hello"), (19,RemTok "GOFORTH\"ANDREAD\"")],
+ [(1,CharTok 'X'), (10,DataTok "TODATA")]
+ ]
+ let accumLensWToks lenAndToks =
+ let (lens, toks) = unzip lenAndToks
+ cols = scanl (+) 1 lens
+ in zip cols toks
+ let expectedColAndTokss = map accumLensWToks expectedLenAndTokss
+ sequence_ $ zipWith assertTokenizerResult source expectedColAndTokss
+
+test_capitalizes_lowercase_chars = TestCase $ do
+ let source = "azAZ"
+ let expected = [(1,CharTok 'A'), (2,CharTok 'Z'), (3,CharTok 'A'), (4, CharTok 'Z')]
+ assertTokenizerResult source expected
+
+test_eats_spaces_after_most_tokens_but_not_chars = TestCase $ do
+ let source = " , + AND ORX YZ "
+ let expectedColAndToks = [(1,SpaceTok), (4,CommaTok), (8,PlusTok), (11,AndTok), (16,OrTok),
+ (18,CharTok 'X'), (19,SpaceTok), (22,CharTok 'Y'), (23,CharTok 'Z'),
+ (24,SpaceTok)]
+ assertTokenizerResult source expectedColAndToks
+
+test_reports_error_for_an_illegal_char = TestCase $ do
+ sequence_ [ assertTokenizerError [illegalChar] "EXPECTING LEGAL BASIC CHARACTER"
+ | illegalChar <- "~`!@#&_[]{}\\'\n\a" ]
+
+test_printToken = TestCase $ do
+ let tokens = [CommaTok, ColonTok, SemiTok, LParenTok, RParenTok, DollarTok, PercentTok, EqTok,
+ NETok, GETok, GTTok, LTTok, PlusTok, MinusTok, MulTok, DivTok, PowTok, AndTok,
+ OrTok, NotTok, LetTok, DimTok, OnTok, GoTok, SubTok, ReturnTok, IfTok, ThenTok,
+ ForTok, ToTok, StepTok, NextTok, PrintTok, InputTok, RandomizeTok, ReadTok,
+ RestoreTok, FnTok, EndTok, StringTok "hello", SpaceTok, RemTok "comment \"here",
+ CharTok 'X', DataTok "DATA,More Data ,5"]
+ let expectedStrings = [",", ":", ";", "(", ")", "$", "%", "=", "<>", ">=", ">", "<", "+", "-",
+ "*", "/", "^", "AND", "OR", "NOT", "LET", "DIM", "ON", "GO", "SUB",
+ "RETURN", "IF", "THEN", "FOR", "TO", "STEP", "NEXT", "PRINT", "INPUT",
+ "RANDOMIZE", "READ", "RESTORE", "FN", "END", "\"hello\"", " ",
+ "REMcomment \"here", "X", "DATADATA,More Data ,5"]
+ assertEqual "" expectedStrings (map printToken tokens)
diff --git a/vintage-basic.cabal b/vintage-basic.cabal
new file mode 100644
--- /dev/null
+++ b/vintage-basic.cabal
@@ -0,0 +1,40 @@
+Name: vintage-basic
+Version: 1.0
+Cabal-Version: >= 1.6
+Stability: experimental
+Synopsis: Interpreter for 1970s-era BASIC
+Description:
+ An interpreter for what is essentially Microsoft BASIC v2,
+ what you might find on a computer in the late 70s or early
+ 80s, such as the Commodore 64.
+ .
+ Rather than making use of traditional stack-based primitives,
+ the implementation uses monad transformers, including one
+ with resumable exceptions that can caught by a program's
+ continuation rather than its context.
+Category: Compilers/Interpreters
+License: BSD3
+License-File: LICENSE.txt
+Author: Lyle Kopnicky
+Maintainer: lyle@vintage-basic.net
+Homepage: http://www.vintage-basic.net
+Build-Type: Simple
+Tested-With: GHC==6.10.1
+Extra-Source-Files: test/Language/VintageBasic/*.hs run_tests.hs examples/*.bas README.txt doc/*.html
+
+Executable vintbas
+ Main-is: Basic.hs
+ Build-Depends: base >=3,
+ array >=0.1,
+ mtl >=1.1,
+ parsec >=2.1,
+ random >=1,
+ time >=1.1,
+ HUnit >=1.2,
+ directory >=1,
+ process >=1,
+ regex-base >=0.72,
+ regex-posix >=0.72,
+ filepath >=1.1
+ HS-Source-Dirs: src
+ GHC-Options: -Wall