Front page | perl.cvs.parrot |
Postings from April 2002
cvs commit: parrot/languages/BASIC README.BASIC alpha.pasm basic.pasm basic.pl basicvar.pasm dumpstack.pasm expr.pasm instructions.pasm sample2.bas sample3.bas sample4.bas stackops.pasm tokenize.pasm wumpus.bas
From:
jgoff
Date:
April 10, 2002 18:26
Subject:
cvs commit: parrot/languages/BASIC README.BASIC alpha.pasm basic.pasm basic.pl basicvar.pasm dumpstack.pasm expr.pasm instructions.pasm sample2.bas sample3.bas sample4.bas stackops.pasm tokenize.pasm wumpus.bas
Message ID:
20020411012600.17650.qmail@netlabs.develooper.com
cvsuser 02/04/10 18:26:00
Added: languages/BASIC README.BASIC alpha.pasm basic.pasm basic.pl
basicvar.pasm dumpstack.pasm expr.pasm
instructions.pasm sample2.bas sample3.bas
sample4.bas stackops.pasm tokenize.pasm wumpus.bas
Log:
Adding clintp's BASIC interpreter.
Revision Changes Path
1.1 parrot/languages/BASIC/README.BASIC
Index: README.BASIC
===================================================================
VERSION
-------
$Id: README.BASIC,v 1.1 2002/04/11 01:25:59 jgoff Exp $
DESCRIPTION
-----------
This is an initial release of a BASIC interpreter hand written
entirely in Parrot bytecode. The NOTES below are intended for Parrot
developers.
This README will always reflect the *current* state of things.
This BASIC is of the fairly old school. Line numbers are required, and
the following keywords are recognized:
LIST
LIST expr-expr
RUN
LOAD progname [loads in progname.bas]
PRINT
PRINT expr
PRINT expr; [supress newline]
DIM [a no-op]
LET var=expr
INPUT var
FOR var=expr TO expr
FOR var=expr TO expr STEP expr
GOSUB expr
RETURN
GOTO expr
GO TO expr [syn with GOTO]
IF expr THEN STATEMENT
READ var
DATA val, val, val, val
RESTORE
END
REM
NEW
QUIT [exits interpreter]
The following functions are supported in the full expression parser:
RND(X) Random number between 0 and X
ABS(X) Absolute value of X
LEN(X) Length of string in X
MID(X,Y,Z)
Return the string of X, starting at position Y (1-based),
for length Z.
ASC(X) Return the ASCII code for the character X
CHR(X) Return the ASCII character for the code X
Additionally, the expression parser understands:
*+/- Operators, will perform them
+ Between two things that don't both look like numbers will
cause concatenation instead.
- Unary minus
, Construction of tuples. 5,I+34*2,"FOO",A$ will be
reduced to a 4-element list (comma-separaed) with all
possible evaluations done.
AND,OR Logical
><<>= Comparison (returns 1 or 0)
BASIC NOTES
-----------
Variable name width: 12
Multidimensional variables: Numeric--total name length w/subscripts, 12
String delimiters: ' and ", interchangeable
Conditionals: < > = and <> (not equal)
Math: Integer arithmetic only
Case sensitive: All statements and keywords
Line numbers: Required, up to 12 digits in length
* GOSUB/FOR-NEXT may be nested to arbitrary depths. Cross-nesting loops, returning
from within a loop, or NEXT within a subroutine will cause the stack to be cleared
back to the appropriate point.
* The values in DATA statements are evaluated at RUNTIME. Thus, it's
entirely possible to put variables in DATA statements
* Anywhere var is indicated, a multidimensional variable (string or array) is allowed.
* Strings do not have to be pre-DIMensioned any longer.
* For IF statements, 0 or empty string is false everything else is true.
* Line lookups are now fast. Well, as reasonably fast as they can be without hashes.
This was intended as a true interactive BASIC (see NOTES below) so that
any of the variables and statements work from the prompt as well as in the
body of the stored program. Entering in a new line number overwrites the line
in the existing program
DISTRIBUTION
------------
Included in this distribution are the following files, some of which may be
of general interest, some only apply to BASIC:
alpha.pasm Alpha/Numeric library
dumpstack.pasm Diagnostic stack dumping
expr.pasm Expression evaluator
stackops.pasm Stack operations
tokenize.pasm A simple string tokenizer
basic.pasm The instruction dispatcher
basicvar.pasm Storage/Retrieval of BASIC strings, numbers,
code
instructions.pasm BASIC instructions
sample.bas Small BASIC example.
sample2.bas Shows off some of the BASIC syntax and instructions
sample3.bas More showing off.
basic.pl Perl Harness for compiling, starting BASIC
in interactive mode.
wumpus.bas Hunt the Wumpus in BASIC
NOTES
-----
Very large programs or very, very large expressions will expose Parrot's GC bugs
quickly. This will manifest itself in a SEGV (likely, hang, garbled output,
or "wrong type on stack" messages.
The expr.pasm module contains a full expression evaluator. It's tied to BASIC through a
few subroutines (to do variable and function resolution) but otherwise it's a general-purpose
evaluator. Of special note is the Infix to Postfix notation conversion function.
TODO
-----
* Implement SAVE
* Optimize variable lookups. They're O(N) now. If the interpreter seems
slow, THIS is why.
That and it's not compiling anything ahead of time.
All runtime interpretation, baby!
CONTACT
-------
Clinton Pierce <clintp@geeksalad.org>
"clintp" irc.rhizomatic.net #perl or #parrot
LICENSE
-------
Redistributable under the terms of any current version of Perl
1.1 parrot/languages/BASIC/alpha.pasm
Index: alpha.pasm
===================================================================
# Test for alphabeticness (7-bit ASCII only)
# Input: (1-char) String on stack (will be removed)
# Output: 0 or 1 (integer) on stack
# Ex: save "<"
# bsr ISALPHA
# restore I2 # False!
#
# $Id: alpha.pasm,v 1.1 2002/04/11 01:25:59 jgoff Exp $
# $Log: alpha.pasm,v $
# Revision 1.1 2002/04/11 01:25:59 jgoff
# Adding clintp's BASIC interpreter.
#
# Revision 1.3 2002/03/31 05:15:31 Clinton
# Adjusted
#
# Revision 1.2 2002/03/31 05:13:32 Clinton
# Id Keywords
#
#
ISALPHA:
pushi
pushs
restore S1
ge S1, "A", UPPER
branch NONUP
UPPER: le S1, "Z", ALPHA
NONUP:
ge S1, "a", LOWER
branch NONLOW
LOWER: le S1, "z", ALPHA
NONLOW:
ge S1, "0", NUMBER
branch NONUM
NUMBER: le S1, "9", ALPHA
NONUM: eq S1, "_", ALPHA
# Not A-Z0-9_
set I1, 0
branch LEAVE_ISALPHA
ALPHA: set I1, 1
LEAVE_ISALPHA:
save I1
popi
pops
ret
# Test for whitespace (tab, space, newline, any low-ASCII stuff)
# Input: (1-char) String on stack (will be removed)
# Output: 0 or 1 (integer) on stack
ISWHITE:
pushi
pushs
set I1, 1
restore S1
le S1, " ", LEAVEWHITE
eq S1, "\n", LEAVEWHITE
eq S1, "\t", LEAVEWHITE
eq S1, "\r", LEAVEWHITE
set I1, 0
LEAVEWHITE:
save I1
popi
pops
ret
# strnchr -- offset first occurance of X in Y
# Inputs: Start offset
# Character on stack (Y)
# String on stack (X)
# Outputs: Offset on stack, -1 if not found
STRNCHR:
pushi
pushs
restore I0 # Offset
restore S0 # Char
restore S1 # String
set S2, ""
set I2, -1 # Not found
length I3, S1
set I4, I0
gt I4, I3, STRNCHRERR
STRNLOOP:
eq I3, I4, ENDSTRNCHR
substr S3, S1, I4, 1
eq S3, S0, STRNGOTONE
inc I4
branch STRNLOOP
STRNGOTONE:
set I2, I4
ENDSTRNCHR:
save I2
popi
pops
ret
STRNCHRERR:
puts "String position out of bounds. ERR\n"
end
# atoi -- String to integer
# Inputs: String on stack
# Outputs: Integer on top of the stack.
# Note: Invalid characters aren't currently handled
# TODO: Ignore spaces
# Ha! Turns out there's already an opcode to do this
# Backwards compatability only!
ATOI: pushi
pushs
restore S0
set I0, S0
save I0
popi
pops
ret
# itoa -- Integer to string
# Inputs: Integer on stack
# Outputs: String on top of the stack
# Ha! Turns out there's already an opcode to do this
# Backwards compatability only!
ITOA: pushi
pushs
restore I0
set S0, I0
save S0
popi
pops
ret
# Stripspace
# Inputs: string on stack
# Outputs: string on stack, less trailing spaces
STRIPSPACE:
pushi
pushs
restore S0
length I0, S0
eq I0, 0, SSDONE
dec I0
SSCHECK:
set S1, ""
substr S1, S0, I0, 1
save S1
bsr ISWHITE
restore I1
eq I1, 0, SSDONE
substr S0, S0, 0, I0
eq I0, 0, SSDONE
dec I0
branch SSCHECK
SSDONE:
save S0
popi
pops
ret
STRIPLEADSPACE:
pushi
pushs
set S0, ""
set S1, ""
restore S0 # Edit me!
SLSLOOP:
length I0, S0
le I0, 0, SLSEXIT
substr S1, S0, 0, 1
ne S1, " ", SLSEXIT
dec I0
substr S0, S0, 1, I0
branch SLSLOOP
SLSEXIT:
save S0
popi
pops
ret
# Stringinsert - Insert string X into Y at position N
# Inputs: Position
# String to Insert
# Target String
# Outputs: Final String
STRINSERT:
pushi
pushs
restore I0
restore S0 # Insert string
restore S1 # Insert into string
set S3, "" # The first part
set S2, "" # The second part
length I1, S1
ne I0, 0, STRNOTZERO
set S2, S1 # Inserting at 0
branch ENDSTRINSERT
STRNOTZERO:
substr S3, S1, 0, I0
substr S2, S1, I0, I1
ENDSTRINSERT:
set S10, ""
concat S10, S3
concat S10, S0
concat S10, S2
save S10
popi
pops
ret
# stringreplace -- Replace Characters in a string
# Inputs: Position
# Number of characters to replce
# String to Insert
# Target String
# Outputs: Final String
#
STRREPLACE:
pushi
pushs
restore I0 # Offset
restore I1 # How many to replace
restore S0 # Insert String
restore S1 # Insert into String
length I3, S1
set S3, "" # First part
set S2, "" # Second part
substr S3, S1, 0, I0
add I0, I0, I1
sub I3, I3, I1
substr S2, S1, I0, I3
set S10, ""
concat S10, S3
concat S10, S0
concat S10, S2
save S10
popi
pops
ret
# pad -- space padding (trailing)
# Inputs: length
# string
# Outputs: string
# NO BOUNDS CHECKING
PAD:
pushi
pushs
restore I0
restore S0
set S1, ""
length I1, S0
concat S1, S0
sub I0, I0, I1
le I0, 0, PADE
repeat S9, " ", I0
concat S1, S9
PADE: save S1
popi
pops
ret
# isnum -- is this thing a number?
# Inputs: string on stack
# Outputs: 1 if it is, 0 if it is not
# Converts to integer and back, if that worked then it's a number.
# (Simple view of the world :)
ISNUM:
pushi
pushs
restore S0 # The thing in question
save S0
bsr ATOI
bsr ITOA
restore S1
eq S1, S0, ISNUM_YES
save 0
branch ENDISNUM
ISNUM_YES:
save 1
ENDISNUM:
popi
pops
ret
1.1 parrot/languages/BASIC/basic.pasm
Index: basic.pasm
===================================================================
# Encode/Decode BASIC instructions and dispatch them
#
# Global Resources
# I20 - Immediate Mode/Run Mode flag =1 RUN =0 IM
# I22 - Please stop running flag
# I23 - Program counter
# I24 - Random number generator seed
# I26 - Line number for last READ
# I27 - Item number for last READ
#
# $Id: basic.pasm,v 1.1 2002/04/11 01:25:59 jgoff Exp $
# $Log: basic.pasm,v $
# Revision 1.1 2002/04/11 01:25:59 jgoff
# Adding clintp's BASIC interpreter.
#
# Revision 1.4 2002/04/07 04:10:07 Clinton
# Can't remember
#
# Revision 1.3 2002/04/01 22:16:54 Clinton
# Added DUMP copcode, protection for random seed
#
# Revision 1.2 2002/03/31 05:13:52 Clinton
# Id Keywords
#
#
# runline -- executes a BASIC instruction
# Inputs: Code line text on stack
# Outputs: 0 everything peachy !=0 Error
#
RUNLINE:
pushi
pushs
set I4, -1
bsr TOKENIZER
bsr REVERSESTACK
RUN_INSERT:
restore I5 # Depth
# This is the insertion point
# for "IF"
eq I20, 0, NOLINE
dec I5
bsr ATOI
restore I4
NOLINE: restore S0
save S0
save I5 # New Depth
save I4 # Line number
set I22, 0 # Error flag
#print "Dispatching "
#print I4
#print "\n"
# Table of all keywords
ne S0, "LOAD", NOT_LOAD
bsr I_LOAD
branch ENDLINE
NOT_LOAD:
ne S0, "REM", NOTREM
bsr I_REM
branch ENDLINE
NOTREM: ne S0, "PRINT", NOTPRINT
bsr I_PRINT
branch ENDLINE
NOTPRINT: ne S0, "LET", NOTLET
bsr I_LET
branch ENDLINE
NOTLET: ne S0, "DIM", NOTDIM
bsr I_DIM
branch ENDLINE
NOTDIM: ne S0, "GOTO", NOTGOTO
bsr I_GOTO
branch ENDLINE
NOTGOTO: ne S0, "GO", NOTGO_TO
bsr I_GOTO
branch ENDLINE
NOTGO_TO: ne S0, "IF", NOTIF
bsr I_IF
branch ENDLINE
NOTIF: ne S0, "FOR", NOTFOR
bsr I_FOR
branch ENDLINE
NOTFOR: ne S0, "NEXT", NOTNEXT
bsr I_NEXT
branch ENDLINE
NOTNEXT: ne S0, "GOSUB", NOTGOSUB
bsr I_GOSUB
branch ENDLINE
NOTGOSUB: ne S0, "RETURN", NOTRETURN
bsr I_RETURN
branch ENDLINE
NOTRETURN:ne S0, "LIST", NOTLIST
bsr I_LIST
branch ENDLINE
NOTLIST: ne S0, "END", NOTEND
bsr I_END
branch ENDLINE
NOTEND: ne S0, "RUN", NOTRUN
bsr I_RUN
branch ENDLINE
NOTRUN: ne S0, "QUIT", NOT_QUIT
end
NOT_QUIT: ne S0, "NEW", NOT_NEW
bsr I_NEW
branch ENDLINE
NOT_NEW: ne S0, "INPUT", NOT_INPUT
bsr I_INPUT
branch ENDLINE
NOT_INPUT: ne S0, "RESTORE", NOT_RESTORE
bsr I_RESTORE
branch ENDLINE
NOT_RESTORE: ne S0, "DATA", NOT_DATA
bsr I_DATA
branch ENDLINE
NOT_DATA: ne S0, "READ", NOT_READ
bsr I_READ
branch ENDLINE
NOT_READ: ne S0, "DUMP", NOT_DUMP
bsr I_DUMP
branch ENDLINE
NOT_DUMP:
RUN_ILL_INSTRUCTION:
restore I4
bsr CLEAR
restore I0 # Dummy
print "BAD KEYWORD at line "
save I4
bsr ITOA
restore S31 # Convert for puts
print S31
print "\n"
save 1
ret
ENDLINE:ne I22, 0, LINEERR
save 0 # No errors
branch NOERR
LINEERR:save I22
NOERR: save S20
save S21
save S22
save I23
save I25
save I26
save I27
save I20
save I24
popi
pops
restore I24
restore I20
restore I27
restore I26
restore I25
restore I23
restore S22
restore S21
restore S20
ret
1.1 parrot/languages/BASIC/basic.pl
Index: basic.pl
===================================================================
#!/usr/bin/perl -w
# BASIC in PASM build harness program
#
# $Id: basic.pl,v 1.1 2002/04/11 01:25:59 jgoff Exp $
# $Log: basic.pl,v $
# Revision 1.1 2002/04/11 01:25:59 jgoff
# Adding clintp's BASIC interpreter.
#
# Revision 1.5 2002/04/07 04:10:07 Clinton
# Debugging
#
# Revision 1.4 2002/04/01 22:16:54 Clinton
# Seed Random Number generator with time
#
# Revision 1.3 2002/03/31 05:14:02 Clinton
# Id Keywords
#
# Revision 1.2 2002/03/31 05:09:57 Clinton
# *** empty log message ***
#
# Revision 1.1 2002/03/31 04:54:21 Clinton
# Initial revision
#
# $Id: basic.pl,v 1.1 2002/04/11 01:25:59 jgoff Exp $
# $Log: basic.pl,v $
# Revision 1.1 2002/04/11 01:25:59 jgoff
# Adding clintp's BASIC interpreter.
#
# Revision 1.5 2002/04/07 04:10:07 Clinton
# Debugging
#
# Revision 1.4 2002/04/01 22:16:54 Clinton
# Seed Random Number generator with time
#
# Revision 1.3 2002/03/31 05:14:02 Clinton
# Id Keywords
#
#
open(T, ">test.pasm") || die;
$a=<<'EOF';
# I5 Stack Depth?
set S20, "#"
set S21, "#"
set S22, "#"
time I24 # Seed the random number generator
branch MAIN
.include stackops.pasm
.include alpha.pasm
.include dumpstack.pasm
.include tokenize.pasm
.include basicvar.pasm
.include basic.pasm
.include instructions.pasm
.include expr.pasm
MAIN:
save 0 # Initialize the runtime stack!
MAINLOOPR:
print "\n\nReady\n"
bsr CLEAR # This should keep the runtime stack clean
MAINLOOPNR:
set I20, 0 # Interactive mode
set S0, ""
set S0, ""
read S0, 256
length I1, S0
eq I1, 1, MAINLOOPR
clone S1, S0
set S0, S1
save S0
bsr STRIPSPACE
restore S0 # This *should* be a no-op, it's not. *puzzle*
save S0 # without it the string retains a trailing CR
bsr TOKENIZER
bsr REVERSESTACK
restore I5
eq I5, 0, ENDMAINLOOPNR # No tokens!
bsr ISNUM
restore I1
dec I5
save I5
bsr CLEAR
restore I0 # dummy
eq I1, 0, DOLINE
save S0
bsr CSTORE
branch ENDMAINLOOPNR
DOLINE:
save S0
bsr RUNLINE
restore I0
branch ENDMAINLOOP
end
ENDMAINLOOP:
branch MAINLOOPR
ENDMAINLOOPNR:
branch MAINLOOPNR
EOF
# Includes and constant substitutions
$a=~s/^\.include (.*)/open(F,$1) and print STDERR "Including $1\n" and join('', <F>)/mge;
$tab{$2}=$3 while($a=~s/^(\.const\s+([^\s]+)\s+([^\s]+))/#$1/m);
for (keys %tab) {
$a=~s/\b${_}\b/$tab{$_}/g ;
}
$b=()=$a=~m/\n/g;
print " $b lines\n";
$a=~s/\bputs\b/print/g; # puts() breaks things.
print T $a;
close(T);
unlink "out.pbc";
system("perl assemble.pl test.pasm > out.pbc");
system("parrot out.pbc");
1.1 parrot/languages/BASIC/basicvar.pasm
Index: basicvar.pasm
===================================================================
# Basic variable and code storage management
#
# Global Resources:
# S20
# S21
# S22 Numeric/String/Code variable storage formatted as:
# 8 bytes (name). Terminates with "#" Line number for Code
# 3 bytes (width) N=12
# width bytes (value)
#
# I18 Cached line number
# I19 Cached line position
#
# Subscripted variables are stored independently of each other as:
# varname|subscr,subscr (the subscripts will be reversed)
# The limit to subscripting is:
# (Length of variable name)[+1+subscriptlen+1+[subscriptlen+1]...
# So that FOO(56,1) will occupy FOO|1,56 an 8-byte slot
#
# $Id: basicvar.pasm,v 1.1 2002/04/11 01:25:59 jgoff Exp $
# $Log: basicvar.pasm,v $
# Revision 1.1 2002/04/11 01:25:59 jgoff
# Adding clintp's BASIC interpreter.
#
# Revision 1.8 2002/04/09 03:14:31 Clinton
# Optimized line lookups by using I18 and I19 as a line number
# cache and pointer
#
# Revision 1.7 2002/04/07 00:52:31 Clinton
# Fixed accidental STRIPSPACE on string storage
#
# Revision 1.6 2002/04/06 21:24:53 Clinton
# Added advanced string handling. String vars are created automagically now
#
# Revision 1.5 2002/04/06 19:58:52 Clinton
# Before allowing undimensioned strings.
# Added VDESTROY capability
#
# Revision 1.4 2002/04/01 22:16:54 Clinton
# Changed load sequence a bit
#
# Revision 1.3 2002/03/31 05:15:31 Clinton
# Adjusted
#
# Revision 1.2 2002/03/31 05:13:48 Clinton
# Id Keywords
#
.const NTYPE 0
.const STYPE 1
.const CTYPE 2
.const NAMEWIDTH 15
.const VARWIDTH 3
.const TERMINATOR "-"
.const STRINGMINW 10
# (internal) Find variable
# Inputs: variable name (or code line number)
# type
# Outputs: offset, -1 if unknown
VFIND: pushi
pushs
restore I5
restore S5
length I0, S5
gt I0, NAMEWIDTH, VFINDTOOLONG
set S15, S20 # Assume Ints
eq I5, NTYPE, VSEARCH
set S15, S21 # Strings?
eq I5, STYPE, VSEARCH
set S15, S22 # Code then
save S5
bsr ATOI
restore I6 # Line numbers are numeric
VSEARCH:
set I0, -1
set I1, 0
ne I5, CTYPE, VFINDL
set I1, I18
VFINDL:
set S2, ""
substr S2, S15, I1, NAMEWIDTH
save S2
bsr STRIPSPACE
restore S2 # Var name/line #
eq S2, S5, VFOUND # Exact match
eq S2, "#", VFINDEND # Exhausted
ne I5, CTYPE, VNOTFOUND
save S2
bsr ATOI
restore I2
ge I2, I6, VFOUND
VNOTFOUND:
add I1, I1, NAMEWIDTH
set S2, ""
substr S2, S15, I1, VARWIDTH
save S2
bsr STRIPSPACE
bsr ATOI
restore I2
add I1, I1, VARWIDTH
add I1, I1, I2
branch VFINDL
VFOUND:
set I0, I1
VFINDEND:
save I0
popi
pops # Read-only no S20 restore needed
ret
VFINDTOOLONG:
print "SYMBOL NAME TOO LONG: "
print S5
print "\n"
end
# Create a variable UNINITIALIZED
# Inputs: Variable name
# type
# width
# Outputs: none
VCREATE:
pushi
pushs
restore I6 # Width
restore I5 # Type
restore S0 # The variable name
set S15, S20 # Assume Ints
eq I5, NTYPE, VCSTART
set S15, S21 # Strings?
eq I5, STYPE, VCSTART
set S15, S22 # Code then
VCSTART:
save "#"
save I5
bsr VFIND # Find the end
restore I0
# Assemble the new
save S0
save NAMEWIDTH
bsr PAD
restore S9
concat S10, S9
save I6
bsr ITOA
save VARWIDTH
bsr PAD
restore S9
concat S10, S9
repeat S9, " ", I6
concat S10, S9
save S15
save S10
save I0
bsr STRINSERT # New is on stack
VCREND: save I5
popi
pops
restore I5
ne I5, NTYPE, VCNOTNUM
restore S20
branch VCBAIL
VCNOTNUM:
ne I5, STYPE, VCNOTSTR
restore S21
branch VCBAIL
VCNOTSTR:
restore S22 # Code
VCBAIL: ret
# Set variables
# (We assume they exist already, a runtime error occurs otherwise)
# Inputs: Value is on the stack
# Name is on the stack
# Width is on the stack
# Outputs: (none)
VSTORE:
pushi
pushs
restore S5 # Value (I will space pad)
restore I6 # width
restore I5 # type
restore S0 # Variable name
save S0
save I5
bsr VFIND
restore I0 # Location
eq I0, -1, VSTOREERR
set S15, S20 # Assume Ints
eq I5, NTYPE, VSSTART
set S15, S21 # Strings?
eq I5, STYPE, VSSTART
set S15, S22 # Code then
VSSTART:
add I0, I0, NAMEWIDTH
substr S1, S15, I0, VARWIDTH
save S1
bsr STRIPSPACE
bsr ATOI
restore I1
ne I1, I6, VSTOREERR2
add I0, I0, VARWIDTH
save S5
save I1
bsr PAD
restore S5
save S15
save S5
save I1
save I0
bsr STRREPLACE
save I5
popi
pops
restore I5
ne I5, NTYPE, VSNOTNUM
restore S20
branch VSBAIL
VSNOTNUM:
ne I5, STYPE, VSNOTSTR
restore S21
branch VSBAIL
VSNOTSTR:
restore S22 # Code
VSBAIL: ret
VSTOREERR:
print "NOVAR for STORE\n"
end
VSTOREERR2:
print "WIDTH MISMATCH for STORE\n"
end
# Fetch variables
# Inputs: Name is on the stack
# Type is on the stack
# Outputs: The value on the stack (AS A STRING)
VFETCH:
pushi
pushs
restore I5 # type
restore S0 # Variable name
save S0
save I5
bsr VFIND
restore I0 # Location
eq I0, -1, VFETCHERR
set S15, S20 # Assume Ints
eq I5, NTYPE, VFSTART
set S15, S21 # Strings?
eq I5, STYPE, VFSTART
set S15, S22 # Code then
VFSTART:
add I0, I0, NAMEWIDTH
substr S1, S15, I0, VARWIDTH
save S1
bsr STRIPSPACE
bsr ATOI
restore I1 # Width of data
add I0, I0, VARWIDTH
substr S1, S15, I0, I1
save S1
popi
pops
ret
VFETCHERR:
print "NOT DEFINED on FETCH\n"
end
# Destroy a variable
# Should only be called by the string stuff when a variable has exceeded maximum
# length and needs to be killed.
# Inputs: Name on stack
# Type on stack
# Outputs: N/A
VDESTROY:
pushi
pushs
restore I5 # Type
save I5
bsr VFIND
restore I0
eq I0, -1, VDESTROYEND
set S15, S20 # Assume Ints
eq I5, NTYPE, VDSTART
set S15, S21 # Strings?
eq I5, STYPE, VDSTART
set S15, S22 # Code then
VDSTART:
add I1, I0, NAMEWIDTH
substr S1, S15, I1, VARWIDTH
save S1
bsr STRIPSPACE
bsr ATOI
restore I2 # Width of var storage entry
add I2, I2, NAMEWIDTH
add I2, I2, VARWIDTH
save S15
save ""
save I2
save I0
bsr STRREPLACE
restore S15
save S15
eq I5, NTYPE, VDNUM
eq I5, STYPE, VDSTRING
eq I5, CTYPE, VDCODE
branch VDFATAL
VDNUM: restore S20
branch VDESTROYEND
VDSTRING:
restore S21
branch VDESTROYEND
VDCODE:
restore S22
branch VDESTROYEND
VDESTROYEND:
save S20
save S21
save S22
popi
pops
restore S22
restore S21
restore S20
ret
VDFATAL:
print "Unknown type in DESTROY"
end
# All of these routines use, misuse and abuse I0, I1, S0, S1, S2
# Should be saved/restored okay though.
# Numeric variable handling
# NCREATE (almost never needed)
# NSTORE
# NFETCH
#
# For all of these the general pattern is:
# push the name
# push the value (if needed)
# call
#
# Create Numeric
.const NUMWIDTH 12
NCREATE:
pushi
pushs
restore S0 # Name
save S0
save NTYPE
bsr VFIND
restore I0
ne I0, -1, NCREATED
save S0
save NTYPE
save NUMWIDTH
bsr VCREATE
save S0
save NTYPE
save NUMWIDTH
save "0"
bsr VSTORE
NCREATED:
save S20
popi
pops
restore S20
ret
# Store numerics
NSTORE:
pushi
pushs
restore I1 # Value
restore S0 # Name
save S0
save NTYPE
bsr VFIND
restore I0
ne I0, -1, NSCREATED
save S0
save NTYPE
save NUMWIDTH
bsr VCREATE
NSCREATED:
save I1
bsr ITOA
restore S1
save S0
save NTYPE
save NUMWIDTH
save S1
bsr VSTORE
save S20
popi
pops
restore S20
ret
# Fetch Numerics
NFETCH: pushi
pushs
restore S0
save S0
save NTYPE
bsr VFIND
restore I0
ne I0, -1, NFCREATED
save S0
bsr NCREATE
NFCREATED:
save S0
save NTYPE
bsr VFETCH
bsr STRIPSPACE
bsr ATOI
save S20
popi
pops
restore S20
ret
# String variable handling
# SCREATE (DIM)
# SSTORE
# SFETCH
# Strings are \n terminated internally
#
# For all of these the general pattern is:
# push the name
# push the value (if needed)
# call
#
# Create String
# DIMENSION is now a no-op.
SCREATE:
pushi
pushs
restore I1 # Dimensioned width
restore S0 # Name
inc I1 # Add one for the terminator
save S0
save STYPE
bsr VFIND
restore I0
ne I0, -1, DIMERROR
save S0
save STYPE
save I1
bsr VCREATE
save S0
save STYPE
save I1
save TERMINATOR
bsr VSTORE
save S21
popi
pops
restore S21
ret
DIMERROR:
print "DIM FAILURE"
end
# Strings are a little smarter now. They work *exactly* like
# numeric variables, except that if the store size exceeds the
# allocated storage we destroy the existing variable and create a new one.
#
SSTORE:
pushi
pushs
restore S1 # Value
restore S0 # Name
save S0
save STYPE
bsr VFIND
restore I0
eq I0, -1, NODIMERR
add I0, I0, NAMEWIDTH
substr S2, S21, I0, 3
save S2
bsr STRIPSPACE
bsr ATOI
restore I1 # Allowable width
#save S1
#bsr STRIPSPACE
#restore S1
length I0, S1
ge I0, I1, STRTOOLONG
concat S1, TERMINATOR
STOREIT:
save S0
save STYPE
save I1
save S1
bsr VSTORE
save S21
popi
pops
restore S21
ret
# These are no longer errors.
# Create a new string slot
# Always create them for at least STRINGMINW
NODIMERR:
concat S1, TERMINATOR
length I1, S1
gt I1, STRINGMINW, LENOKAY
set I1, STRINGMINW
LENOKAY:save S0
save STYPE
save I1
bsr VCREATE
branch STOREIT
# Destroy the old slot, create a new one
STRTOOLONG:
save S0
save STYPE
bsr VDESTROY
branch NODIMERR
# Fetch a string
# If the string wasn't previously dimensioned then
# we return the empty string
SFETCH:
pushi
pushs
restore S0 # Name
save S0
save STYPE
bsr VFIND
restore I0
ne I0, -1, GETSVAL
set S1, ""
branch RETSVAL
GETSVAL:save S0
save STYPE
bsr VFETCH
bsr STRIPSPACE
restore S1
length I1, S1 # chopn S1, 1
dec I1
substr S1, S1, 0, I1
RETSVAL:save S1
set S1, S1 # Fix bug?
popi
pops # No state-saving needed
ret
# Code Storage and Retrieval
# This...is...insane. Takes arguments as though strings
#
# CSTORE -- store a code line, overwriting existing lines.
# CFETCH -- fetch a code line. NOTE: you'll get the line
# specified or *higher*
# Fetch a line to be decoded.
# Inputs: Integer line number (on stack)
# Outputs: The line number (integer) found (-1 if none)
# The corresponding line or *the next higher*
#
# Line lookups now *start* where the last one left off. For forward
# jumps, this means that only backwards jumps are O(n)
#
# I18 is the offset where the last line was found.
# I19 is the last line number found.
#
CFETCH: pushi
pushs
restore I1 # Line number we want
gt I1, I19, INCACHE
set I18, 0
INCACHE:
save I1
bsr ITOA
save CTYPE
bsr VFIND
restore I0 # Offset, line that was found.
eq I0, -1, CNOLINE
set I18, I0 # Where to start next time
substr S3, S22, I0, NAMEWIDTH
save S3
bsr STRIPSPACE
bsr ATOI
restore I3
add I0, I0, NAMEWIDTH
substr S4, S22, I0, VARWIDTH
save S4
bsr STRIPSPACE
bsr ATOI
restore I1 # Length
add I0, I0, VARWIDTH
substr S4, S22, I0, I1
save S4
bsr STRIPSPACE
restore S4
length I2, S4 # chopn S4, 1
dec I2
substr S4, S4, 0, I2
save S4 # The line
save I3 # The line number
set I19, I3 # Remember me.
save I19
save I18
popi
pops
restore I18
restore I19
ret
CNOLINE:
set I18, 0
set I19, 0
save -1
popi
pops
ret
# CSTORE
# Inputs: A code line on the stack. Must be formatted like this:
# \d+\s
# Outputs: Nothing
# Trashes I0-I4, S0-S4
CSTORE:
pushi
pushs
set I8, 0 # One-token-only flag
restore S0 # Safekeeping
save S0
bsr TOKENIZER
bsr REVERSESTACK
restore I0 # Depth
ne I0, 1, ONELNCK
set I8, 1 # Just the line number!
ONELNCK:
restore S1 # Line number
dec I0
save I0
bsr CLEAR # Empty the stack
save S1
bsr ATOI
restore I1 # Number as numeric
lt I1, 1, ENOTVALIDLINE
# This is fucking ugly. :)
# Load the stack up with the lines so far, skipping the
# one entry we (might be) replacing.
set I2, 0 # Depth
set I0, 0
eq I8, 1, CNEXT # Don't add if it's just a number
save S0 # The line we're adding
inc I2
CNEXT:
set S3, ""
substr S3, S22, I0, NAMEWIDTH
save S3
bsr STRIPSPACE
restore S3
eq S3, "#", CEND
add I0, I0, NAMEWIDTH
set S4, ""
substr S4, S22, I0, VARWIDTH
save S4
bsr STRIPSPACE
bsr ATOI
restore I1
add I0, I0, VARWIDTH
set S4, ""
substr S4, S22, I0, I1
add I0, I0, I1
save S4
bsr STRIPSPACE
restore S4
length I3, S4
dec I3
substr S4, S4, 0, I3
eq S1, S3, CNEXT # Skipping this line
save S4 # The line
inc I2
branch CNEXT
# At this point the stack is full of stuff
# Sort it.
CEND: save I2
CENDLOAD: # Entry point for LOAD
bsr REVERSESTACK
bsr LSORTSTACK
bsr REVERSESTACK
# Take the stack and re-insert it as lines
set S22, "#"
set I0, 0
restore I1
set I0, I1
# Stuff the lines into the storage area
ADDLINE:
eq 0, I0, DONEADD
set S0, ""
restore S0 # Whole line
save S0
save " "
save 0
bsr STRNCHR
restore I2
set S1, ""
substr S1, S0, 0, I2
concat S0, TERMINATOR
length I2, S0
save S1
save CTYPE
save I2
bsr VCREATE
save S1
save CTYPE
save I2
save S0
bsr VSTORE
dec I0
branch ADDLINE
DONEADD:
save S22
popi
pops
restore S22
ret
ENOTVALIDLINE:
print "BAD LINE NUMBER\n"
end
# Sort whatever's on the stack.
# This is a modified version of sortstack, sorts numerically by the first field
#
LSORTSTACK:
pushi
pushs
# Assume that rotate_up as defined in the original problem
# statement has been defined.
restore I5 # local $len = pop(@stack);
set I6, I5 # local $bum = $len;
# local ($x, $y, $limit);
LSORTMORE:
le I6,1,LENDSORT # while ($bum > 1) {
set I7, I6 # $limit = $bum;
LSHUFFLE:
dec I7
eq I7, 0, LALMOSTDONE # while (--$limit) {
bsr GETLINENO
restore I2
restore S2 # $x = pop(@stack);
bsr GETLINENO
restore I3
restore S3 # $y = pop(@stack);
# le S2, S3, LSORTSWAP
le I2, I3, LSORTSWAP # if ($x gt $y) {
savec S2 # push(@stack, $x);
savec S3 # push(@stack, $y);
branch LROT # }
LSORTSWAP: # else {
savec S3 # push(@stack, $y);
savec S2 # push(@stack, $x); }
LROT:
rotate_up I6 # rotate_up($bum);
branch LSHUFFLE # }
LALMOSTDONE: # At end of the $limit loop, top element is the max, and
# top+1 to end is semi-sorted. One more rotate_up()
# is needed before moving the floor up one notch.
rotate_up I6 # rotate_up($bum);
dec I6 # $bum--; }
branch LSORTMORE
LENDSORT:
save I5
popi
pops
ret
# Inputs: Code line
# Outputs: Line number on stack as integer
# Code line underneath
GETLINENO:
pushi
pushs
restore S2
save S2
save " "
save 0
bsr STRNCHR
restore I3
set S7, ""
substr S7, S2, 0, I3
save S7
bsr ATOI
restore I0
savec S2
save I0
popi
pops
ret
# Vardecode
# All-purpose variable decoder. It's kinda blind though, so when you call it
# had better be a varaible there or the results are... unpredictable.
# Deals with "A$" as one *or* two tokens!
# Inputs: Stopword for evaluation
# Normal stack. With what you *think* is the start of the variable
# on top. A$ ...
# Outputs: Type (NTYPE, STYPE, CTYPE, etc...) on top then the name.
# Array variables will be encoded in such a way they can be looked up
# as-is.
VARDECODE:
pushi
pushs
set S3, ""
restore S3 # Stopword
restore I5 # Depth
restore S1 # Variable name
set I3, NTYPE # Numeric (assume)
dec I5
set S5, "" # Check for 1-token string vars.
length I2, S1
substr S5, S1, I2, 1
eq S5, "$", DECSTRING
eq I5, 0, VARDECODED # Nothing left it has to be numeric
restore S2 # $, ( or stopword
dec I5
ne S2, "$", FINDEC
DECSTRING:
set I3, STYPE
eq I5, 0, VARDECODED
restore S2 # There's something else...
dec I5
FINDEC: # S2's either the stop, expression, something.
save S2
inc I5
eq S2, "(", VARSUBSCRIPT
branch VARDECODED # Nothing more to see here.
VARSUBSCRIPT:
save I5
save S3 # Stop word
bsr EVAL_EXPR
restore S0 # Subscript
concat S1, "|"
concat S1, S0 # var|expr[,expr...]
restore I5
VARDECODED:
save I5 # Fix the stack
save S1 # Save the name
save I3 # Save the type
popi
pops
ret
1.1 parrot/languages/BASIC/dumpstack.pasm
Index: dumpstack.pasm
===================================================================
# User Stack Dump (Debugging.)
# Inputs: Top of stack should contain the depth
# Outputs: Top of stack should (still) contain the depth. :)
# Types
# 1 is an int
# 2 is a num
# 3 is a string
# 4 is a PMC
#
# $Id: dumpstack.pasm,v 1.1 2002/04/11 01:25:59 jgoff Exp $
# $Log: dumpstack.pasm,v $
# Revision 1.1 2002/04/11 01:25:59 jgoff
# Adding clintp's BASIC interpreter.
#
# Revision 1.3 2002/03/31 05:15:31 Clinton
# Adjusted
#
# Revision 1.2 2002/03/31 05:13:39 Clinton
# Id Keywords
#
#
DUMPSTACK:
pushi
pushn
pushs
pushp
puts "Stack Dump: (top to bottom)\n"
restore I5
set I0, I5
gt I5, 0, DUMPLOOP
puts " -empty-\n"
branch DUMPEND
DUMPLOOP:
entrytype I1, 0
puts " "
sub I2, I5, I0
save I2
bsr ITOA
restore S31 # Convert for puts
puts S31
puts " "
ne I1, 1, DUMPNOTINT
puts "Int "
restore I1
save I1
save I1
bsr ITOA
restore S31 # Convert for puts
puts S31
branch DUMPANOTHER
DUMPNOTINT:
ne I1, 2, DUMPNOTNUM
puts "Num "
restore N0
save N0
#print N0
branch DUMPANOTHER
DUMPNOTNUM:
ne I1, 3, DUMPNOTSTRING
puts "Str "
restore S1
save S1
puts S1
branch DUMPANOTHER
DUMPNOTSTRING:
ne I1, 4, DUMPERR
puts "PMC "
restore P0
save P0
#print P0
branch DUMPANOTHER
DUMPANOTHER:
puts "\n"
rotate_up I5
dec I0
eq I0, 0, DUMPEND
branch DUMPLOOP
DUMPEND:
save I5
popi
popn
pops
popp
ret
DUMPERR:
puts "UNKNOWN TYPE\n"
end
1.1 parrot/languages/BASIC/expr.pasm
Index: expr.pasm
===================================================================
# Expression Evaluation routines
#
# Global Variables:
# S24 -- the pseudo stack. Set to "" to reset the stack.
# accessed through PUSHOPSTACK, POPOPSTACK, OPSTACKDEPTH
# I24 -- Random number generator seed
#
# There are external dependancies on stackops, basicvars, and alpha.
#
# TODO: A space on the op stack will be reduced to an empty expression
# fix PUSHOPSTACK/POPOPSTACK when not so exhausted...
#
# $Id: expr.pasm,v 1.1 2002/04/11 01:25:59 jgoff Exp $
# $Log: expr.pasm,v $
# Revision 1.1 2002/04/11 01:25:59 jgoff
# Adding clintp's BASIC interpreter.
#
# Revision 1.6 2002/04/08 02:37:40 Clinton
# Added conditionals and logical operators to expr and tests
#
# Revision 1.5 2002/04/07 00:52:47 Clinton
# The + operator now will concatenate if either arg looks non-numeric
#
# Revision 1.4 2002/04/06 23:33:49 Clinton
# Added the TIME() function to return Epoch Time
#
# Revision 1.3 2002/04/01 22:16:54 Clinton
# Changed RND() to be a bit more random
# Fixed code for nested parenthetical functions/variables
#
# Revision 1.2 2002/03/31 05:13:59 Clinton
# Id Keywords
#
# Width of things on the pseudo-stack
.const STACKSIZE 80
# Some stack stuff. Allows me to move things from one stack to another, etc..
#
PUSHOPSTACK:
pushs
restore S0
#print "Pushing "
#print S0
#print "\n"
concat S0, TERMINATOR # Marker
save S0
save STACKSIZE
bsr PAD
restore S0
concat S24, S0
savec S24
pops
restore S24
ret
POPOPSTACK:
pushi
pushs
length I0, S24
sub I1, I0, STACKSIZE
substr S0, S24, I1, STACKSIZE
substr S24, S24, 0, I1
savec S0
bsr STRIPSPACE
restore S0
length I0, S0
dec I0
substr S0, S0, 0, I0 # Remove trailing
#print "Popping "
#print S0
#print "\n"
save S0
savec S24
popi
pops
restore S24
ret
OPSTACKDEPTH:
pushi
length I0, S24
div I0, I0, STACKSIZE
save I0
popi
ret
# Function Dispatcher and Test
# Functions are dispatched from here. BASIC functions have a *FIXED* number of
# arguments. When the function code is called one of two things will happen:
# * If I10 is set to 1, the function just needs to acknowledge that it exists
# by incrementing I10 to 2 and returning. Don't look at the stack.
# * The stack is well-formed
# The top item on the stack is the first argument. Next item, next arg.
# * Function should exhaust the stack and leave its response on TOP as a STRING
#
# ERRORS:
# When they get confused they put a "0" on the stack and issue a warning message.
# Things are still clean.
#
# entrypoint....
# ISFUNC: Call with func name on stack, returns 1 or 0 on stack.
ISFUNC:
pushi
pushs
set I10, 1 # Only test and return.
save 1 # Falsify stack
branch FUNCDISPATCH
# entrypoint....
# STFUNCDISPATCH: Call with canonical stack, function name first entry.
STFUNCDISPATCH:
pushi
pushs
set I10, 0 # Actually *DO* the function.
FUNCDISPATCH:
restore I5
restore S0 # Function to call.
dec I5
save I5
# Okay, while the function's on the stack being processed it
# might have this ! thing after it. Remove it.
set S3, ""
length I0, S0
dec I0
substr S3, S0, I0, 1
ne S3, "!", FUNCJUMP
substr S0, S0, 0, I0
# To add a function, add to this jump table. Follow the rules above.
#
FUNCJUMP:
eq S0, "ABS", FUNC_ABS
eq S0, "LEN", FUNC_LEN
eq S0, "RND", FUNC_RND
eq S0, "MID", FUNC_MID
eq S0, "ASC", FUNC_ASC
eq S0, "CHR", FUNC_CHR
eq S0, "TIME", FUNC_TIME
eq I10, 1, ENDISFUNC # Just checking, must not have been there.
# This is bad, mmkay. We called a function that's not a function!
# It's probably *actually* a subscripted variable. Assume that and
# jump to an evaluator to go lookup the array variable.
branch DOSUBSCRIPT
ENDFUNCDISPATCH: # Answer's on top, remember?
save I24
popi
pops
restore I24 # Random number seed.
ret
ENDISFUNC:
restore I0 # The fake depth we used before
dec I10 # 2->1 1->0
save I10
popi
pops
ret
# Here's some functions!
# Do *not* return.
# Jump to ENDISFUNC for a query or ENDFUNCDISPATCH for a call.
#
FUNC_ABS:
inc I10
gt I10, 1, ENDISFUNC # Only checking!
restore I5 # pulling ABS's arguments (strings)
ne I5, 1, FUNC_ERR # Wrong number of args.
bsr ATOI
restore I0
save I0
ge I0, 0, ENDFUNCDISPATCH
restore I0
mul I0, I0, -1
save I0
bsr ITOA
branch ENDFUNCDISPATCH
# Returns the Epoch seconds (core op TIME INT)
FUNC_TIME:
inc I10
gt I10, 1, ENDISFUNC
restore I5
ge I5, 1 FUNC_ERR # No arguments for time()
time I0
save I0
bsr ITOA
branch ENDFUNCDISPATCH
FUNC_LEN:
inc I10
gt I10, 1, ENDISFUNC # Only checking!
restore I5
ne I5, 1, FUNC_ERR
restore S1
length I0, S1
save I0
bsr ITOA
branch ENDFUNCDISPATCH
# The old seed is kept in
# Uses X[n+1]=(a*x[n]+c) mod m
# Where, a=5, c=1, and m is the range
# I24 is the seed. The period is 65536
# and probably isn't fair in the low bits.
#
FUNC_RND:
inc I10
gt I10, 1, ENDISFUNC # Only checking!
restore I5
ne I5, 1, FUNC_ERR
bsr ATOI
restore I0 # Range for random
mul I24, I24, 5 # *a
add I24, I24, 1 # +c
mod I24, I24, 65536 # % m
mod I0, I24, I0
save I0
bsr ITOA
branch ENDFUNCDISPATCH
FUNC_MID:
inc I10
gt I10, 1, ENDISFUNC
restore I5
ne I5, 3, FUNC_ERR
restore S1 # the string
bsr ATOI
restore I0 # start
dec I0 # (1-based)
bsr ATOI
restore I1 # length
length I2, S1
gt I0, I2, FUNC_MID_ERR1
add I3, I0, I1
gt I3, I2, FUNC_MID_ERR2
substr S2, S1, I0, I1
save S2
branch ENDFUNCDISPATCH
FUNC_CHR:
inc I10
gt I10, 1, ENDISFUNC
restore I5
ne I5, 1, FUNC_ERR
bsr ATOI
restore I0 # The number
gt I0, 255, FUNC_ASCII_ERROR
bsr SET_S1_ASCII
substr S0, S1, I0, 1
save S0
branch ENDFUNCDISPATCH
FUNC_ASC:
inc I10
gt I10, 1, ENDISFUNC
restore I5
ne I5, 1, FUNC_ERR
restore S0 # The character
bsr SET_S1_ASCII
save S1 # The set
save S0 # The character
save 0
bsr STRNCHR
restore I0
eq I0, -1, FUNC_ASCII_ERROR
save I0
bsr ITOA
branch ENDFUNCDISPATCH
# Re-used a few places. :)
# Boy, is this handy.
SET_S1_ASCII:
set S1, "\x0\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4a\x4b\x4c\x4d\x4e\x4f\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5a\x5b\x5c\x5d\x5e\x5f\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6a\x6b\x6c\x6d\x6e\x6f\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7a\x7b\x7c\x7d\x7e\x7f\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff"
ret
# Errors for the functions.
#
FUNC_MID_ERR1:
print "MID(): start bound "
print I0
print " exceeds length of "
print I2
print "\n"
save "0"
branch ENDFUNCDISPATCH
FUNC_MID_ERR2:
print "MID(): end bound of "
print I3
print " exceeds length of "
print I2
print "\n"
save "0"
branch ENDFUNCDISPATCH
FUNC_ASCII_ERROR:
print "CHR/ASC: bounds error\n"
save "0"
branch ENDFUNCDISPATCH
FUNC_ERR:
print "Improper arguments to "
print S0
print "\n"
save "0"
save I5 # Now clear the stack!
bsr CLEAR
restore I5
branch ENDFUNCDISPATCH
#
# End of functions
#
# This is the subscripted variable lookup, called by the function dispatcher.
# We're still in its scope! Don't forget to popi, pops, etc...
# We've got a well-formed stack here.
# *** S0 WILL CONTAIN THE VARIABLE NAME ***
DOSUBSCRIPT:
# S0 has the variable name.
set I3, NTYPE # Numeric
length I0, S0
set S1, ""
dec I0
substr S1, S0, I0, 1 # Peel off last char
ne S1, "$", DOSUBNUM
set I3, STYPE # String
substr S0, S0, 0, I0
DOSUBNUM:
concat S0, "|"
restore I5
DOSUBSL:
eq I5, 0, ENDSUBS
restore S1
dec I5
concat S0, S1
eq I5, 0, ENDSUBS
concat S0, ","
branch DOSUBSL
ENDSUBS:
save S0
eq I3, NTYPE, DOSUBFNUM
bsr SFETCH
branch DOSUBRET
DOSUBFNUM:
bsr NFETCH
bsr ITOA
DOSUBRET:
save I24 # Random number seed.
popi
pops
restore I24
ret
# The expression evaluator
#
# Call with:
# Stop word on top
# Well-formed stack underneath
# Returns with:
# The result on top
# The unneeded part of the stack underneath (well-formed)
#
# Operator Precedence:
# ~ (Function bind)
# * /
# + -
# ,
#
# Unresolved expressions such as: (4,5,6) will be returned as
# is, reduced as far as things allow.
#
# The following features are allowed:
# Integers
# Unary -
# Binary ops: * / + -
# Functions: (defined above)
# Variables: Numeric and string
# Array variables: Numeric and string (strings cannot be set by LET, TODO)
# Numbers and Strings are silently interchangeable
#
EVAL_EXPR:
pushs
pushi
set S24, "" # clear the multipurpose stack
restore S1 # Stop word
restore I5
# Split the stack into two well-formed stacks:
# One before the stopword (not incl.) one after (incl.)
EVAL_SPLIT:
eq I5, 0, ENDSPLIT
restore S0
save S0
eq S0, S1, ENDSPLIT
dec I5
bsr PUSHOPSTACK
branch EVAL_SPLIT
ENDSPLIT:
save I5 # Put what's left back
set I5, 0
REBUILD:
bsr OPSTACKDEPTH
restore I0
eq I0, 0, NOWCOOK
bsr POPOPSTACK
inc I5
branch REBUILD
NOWCOOK:
save I5
bsr COOK_EXPR # First cook it a bit
bsr INFIXPOSTFIX # Convert from Infix to Postfix
bsr DOCALC
save I24
pops
popi
restore I24
ret
# First, cook the expression a bit for easy digestion
# * Unary - is properly joined with its argument
# * $'s are re-attached to their string variable names
# * Functions and array lookups are converted from:
# FUNC(x,y,z) ARR(a,b,c) to:
# FUNC!~(x,y,z) ARR!~(a,b,c)
# When converted to RPN, this makes matching the func with its
# arguments sane again
#
COOK_EXPR:
pushi
pushs
restore I5
set S24, "" # Stack thingy
set I6, 1 # Unary flag
set I7, 0 # func flag
set I8, 0 # Seen < flag
FIXUNARY:
eq I5, 0, ENDFIXU
restore S0
dec I5
ne S0, "$", NOTDOLLAR
bsr POPOPSTACK
restore S1
concat S1, "$"
savec S1
bsr PUSHOPSTACK
branch FIXUNARY
NOTDOLLAR:
ne S0, "(", CHECKUM # Got a (
eq I7, 0, CHECKUM # and the funcflag is set!
bsr POPOPSTACK
restore S3
concat S3, "!"
savec S3
bsr PUSHOPSTACK
savec "~"
bsr PUSHOPSTACK
# Fall through Ok.
CHECKUM:
ne S0, "-", GTCHECK # Got a -
eq I6, 0, UNCHECK # and the unary flag is set!
restore S0
dec I5
set S1, "-"
concat S1, S0
set S0, S1
branch ADDUSTACK
GTCHECK:
ne S0, ">", UNCHECK
ne I8, 1, UNCHECK
bsr POPOPSTACK
restore S0
concat S0, ">"
save S0
bsr PUSHOPSTACK
branch FIXUNARY
# Decide if a trailing - can or cannot be unary.
UNCHECK:
set I6, 0
set I7, 0
eq S0, "/", POSSUN # If any of these are
eq S0, "*", POSSUN # found then the next "-"
eq S0, "-", POSSUN # is syntatically a unary -
eq S0, "+", POSSUN
eq S0, "(", POSSUN
eq S0, "<", POSSUN
eq S0, ">", POSSUN
eq S0, "=", POSSUN
eq S0, ",", POSSUN
eq S0, "<>", POSSUN
eq S0, "OR", POSSUN
eq S0, "AND", POSSUN
eq S0, ")", ADDUSTACK # Not this. :)
# We have a variable, function, token of some kind.
# if an open paren follows, this is a function call
set I7, 1
branch ADDUSTACK
POSSUN:
set I6, 1 # The next thing may be a unary minus
set I8, 0
ne S0, "<", ADDUSTACK
set I8, 1
ADDUSTACK:
savec S0
bsr PUSHOPSTACK
branch FIXUNARY
ENDFIXU: # Stack transfer.
bsr OPSTACKDEPTH
restore I0
eq I0, 0, COOKEXIT
bsr POPOPSTACK
restore S0
save S0
inc I5
branch ENDFIXU
COOKEXIT:
save I5
popi
pops
ret
# Infix -> Postfix conversion
#
# Input: Well-formed stack leftmost on top
# Output: Well-formed stack, first to be processed on top
#
# Bit-O-Magic, | is used to separate tokens on output stream
.const SEPARATOR "|"
INFIXPOSTFIX:
pushi
pushs
restore I5 # Stack depth
set S24, ""
set S0, "" # The postfix stack
set S7, "" # Input
GETTOP:
le I5, 0, FINISH
restore S7
dec I5
eq S7, "-", SPECIAL
eq S7, "+", SPECIAL
eq S7, "*", SPECIAL
eq S7, "/", SPECIAL
eq S7, "(", SPECIAL
eq S7, ")", SPECIAL
eq S7, "~", SPECIAL
eq S7, ">", SPECIAL
eq S7, "<", SPECIAL
eq S7, "=", SPECIAL
eq S7, "<>", SPECIAL
eq S7, "AND", SPECIAL
eq S7, "OR", SPECIAL
concat S0, S7 # An identifier
concat S0, SEPARATOR
branch GETTOP
SPECIAL:
eq S7, "(", OPENPAREN
branch CLOSEPARENCK
OPENPAREN:
save "("
bsr PUSHOPSTACK
#print "Saved (\n"
branch GETTOP
CLOSEPARENCK:
eq S7, ")", CLOSEPAREN
branch CANPUSH
CLOSECOMMA:
bsr OPSTACKDEPTH
restore I0
eq I0, 0, FINISHCOMMA
bsr POPOPSTACK
restore S1
eq S1, "(", FINISHCOMMA
#print "Concatting "
#print S7
#print "\n"
concat S0, S7
concat S0, SEPARATOR
branch CLOSECOMMA
FINISHCOMMA:
ne S7, "(", FC2 # Really processing a (?
save "("
bsr PUSHOPSTACK
FC2:
concat S0, ",<"
concat S0, SEPARATOR
branch GETTOP
CLOSEPAREN:
bsr OPSTACKDEPTH
restore I0
#print "In closeparen, Stack depth: "
#print I0
#print " "
#print S24
#print "\n"
eq I0, 0, GETTOP
bsr POPOPSTACK
set S1, ""
restore S1
eq S1, "(", TILDECK
#print "Adding "
#print S1
#print " because of closeparen\n"
concat S0, S1
concat S0, SEPARATOR
branch CLOSEPAREN
# Okay, found an ) went back to (, is the next thing a ~ ?
TILDECK:
bsr OPSTACKDEPTH
restore I0
eq I0, 0, GETTOP # Nope, apparently not.
bsr POPOPSTACK
set S1, ""
restore S1
eq S1, "~", GOTTILDE
save S1
bsr PUSHOPSTACK # Oops, sorry.
branch GETTOP
GOTTILDE:
concat S0, S1 # Mash that tilde on there.
concat S0, SEPARATOR
branch GETTOP
CANPUSH:
#print "In canpush with "
#print S7
#print "\n"
bsr OPSTACKDEPTH
restore I0
ne I0, 0, NOTMTSTACK
save S7
bsr PUSHOPSTACK
branch GETTOP
NOTMTSTACK:
bsr POPOPSTACK
set S10, ""
restore S10 # Last op
ne S10, "(", NOTPAREN
save S10
bsr PUSHOPSTACK
save S7
bsr PUSHOPSTACK
branch GETTOP
NOTPAREN:
set I2, 1 # Medium (default) precedence
set I3, 1
eq S7, "~", IN_10
eq S7, "*", IN_8
eq S7, "/", IN_8
eq S7, "+", IN_6
eq S7, "-", IN_6
eq S7, "<", IN_4
eq S7, ">", IN_4
eq S7, "<>", IN_4
eq S7, "=", IN_4
eq S7, "AND", IN_2
eq S7, "OR", IN_2
branch CKLASTOP
IN_10: inc I2
IN_8: inc I2
IN_6: inc I2
IN_4: inc I2
IN_2: inc I2
CKLASTOP:
eq S10, "~", LT_10
eq S10, "*", LT_8
eq S10, "/", LT_8
eq S10, "+", LT_6
eq S10, "-", LT_6
eq S10, "<", LT_4
eq S10, ">", LT_4
eq S10, "<>", LT_4
eq S10, "=", LT_4
eq S10, "AND", LT_2
eq S10, "OR", LT_2
branch CKPREC
LT_10: inc I3
LT_8: inc I3
LT_6: inc I3
LT_4: inc I3
LT_2: inc I3
CKPREC:
le I2, I3, APPOP
save S10
bsr PUSHOPSTACK
save S7
bsr PUSHOPSTACK
branch GETTOP
APPOP:
concat S0, S10
concat S0, SEPARATOR
branch CANPUSH
FINISH:
bsr OPSTACKDEPTH
restore I0
eq I0, 0, ALLDONE
bsr POPOPSTACK
restore S7
concat S0, S7
bsr OPSTACKDEPTH
restore I0 # Bug fix...
concat S0, SEPARATOR
eq I0, 0, ALLDONE
branch FINISH
# The RPN is finished here, stored in S0 as a stream.
# we need to produce a valid stack from that. DON'T
# USE TOKENIZE. It's too smart for this.
ALLDONE:
#print "RPN:"
#print S0
#print "\n"
set I5, 0
set I0, 0 # Offset
set I1, 0 # Oldstart
NEXTTOK:
save S0
save SEPARATOR
save I0
bsr STRNCHR
set I1, I0
restore I0
eq I0, -1, ENDINFIX
set S1, ""
sub I2, I0, I1
substr S1, S0, I1, I2
save S1
add I0, I1, I2
inc I0
inc I5
branch NEXTTOK
ENDINFIX:
save I5 # Stack's proper
popi
pops
ret
# Calulate
# Input: A well-formed stack in RPN notation
# Output: The value evaluated on top of the stack or 0 if an error occurred.
# (a message will be emitted separately)
#
DOCALC:
pushi
pushs
set S24, ""
bsr REVERSESTACK
restore I5
set S0, ""
CALCLOOP:
le I5, 0, CALCFINISH
restore S0
dec I5
save S0
bsr ISNUM
restore I1
ne I1, 1, NOTNUM
save S0
bsr PUSHOPSTACK
branch CALCLOOP
NOTNUM:
# Thing here is func, var, op, string, multidim var
eq S0, "*", DOOP
eq S0, "/", DOOP
eq S0, "+", DOOP
eq S0, "-", DOOP
eq S0, "<", DOOP
eq S0, ">", DOOP
eq S0, "=", DOOP
eq S0, "<>", DOOP
eq S0, "AND", DOOP
eq S0, "OR", DOOP
eq S0, "~", DOFUNC
eq S0, ",", PUSHVAR # ?
# Is it a builtin?
save S0
bsr ISFUNC
restore I0
ne I0, 1, NOTBUILTIN
# Pulled a function, go take care of it
save S0
bsr PUSHOPSTACK
branch CALCLOOP
# Now, we've got one of
# var(index[, index...])
# var
# "string"
NOTBUILTIN:
set S1, ""
substr S1, S0, 0, 1
eq S1, "'", STRING
eq S1, '"', STRING
branch NOTSTRINGLIT
STRING:
length I0, S0
sub I0, I0, 2
substr S0, S0, 1, I0
save S0
bsr PUSHOPSTACK
branch CALCLOOP
NOTSTRINGLIT:
# Okay, the thing here is either
# 1. var
# 2. var(....) w/trailing !
set S3, ""
length I0, S0
dec I0
substr S3, S0, I0, 1
ne S3, "!", NORMVAR
save S0 # A var(...), resolve later.
bsr PUSHOPSTACK
branch CALCLOOP
# It's a variable. Resolve it now, please.
NORMVAR:
set S3, ""
length I0, S0
dec I0
substr S3, S0, I0, 1
eq S3, "$", RES_STRINGVAR
# Numeric var
save S0
bsr NFETCH # Get the numeric value
bsr ITOA
restore S0
branch PUSHVAR
RES_STRINGVAR:
substr S0, S0, 0, I0 # Now has an alpha var
save S0
bsr SFETCH
restore S0
branch PUSHVAR
PUSHVAR:save S0
bsr PUSHOPSTACK
branch CALCLOOP
# Actually perform a math operation
# strings on the stack are silently converted to numeric
# variables and functions should already have been resolved
# Joy! If either thing is *not* a number, then + should concatenate.
#
DOOP: set I2, 0
set I3, 0
set I8, 0 # Perform normal addition
set S12, ""
set S13, ""
bsr OPSTACKDEPTH
restore I0
eq I0, 0, NOSTACK
bsr POPOPSTACK
restore S12
save S12
bsr ISNUM
restore I0
eq I0, 1, OPNUM1
inc I8
OPNUM1:
save S12
bsr ATOI
restore I2
bsr OPSTACKDEPTH
restore I0
eq I0, 0, NOSTACK
bsr POPOPSTACK
restore S13
save S13
bsr ISNUM
restore I0
eq I0, 1, OPNUM2
inc I8
OPNUM2:
save S13
bsr ATOI
restore I3
# Okay, at this point we've got either
# S12 I2 (alpha/num)
# S13 I3
NOSTACK:ne S0, "+", SUB
eq I8, 0, NUMADD
set S4, ""
concat S13, S12
set S4, S13
branch ENDOP # Note different branch
# Numeric ops
NUMADD: add I4, I2, I3
branch ENDNOP
SUB: ne S0, "-", MUL
sub I4, I3, I2
branch ENDNOP
MUL: ne S0, "*", DIV
mul I4, I3, I2
branch ENDNOP
DIV: ne S0, "/", EQ
div I4, I3, I2
branch ENDNOP
# Mixed ops
# set to 0 or 1, branch to ENDNOP when done
EQ: ne S0, "=", NE
set I4, 1 # Assume true
eq I8, 0, NEQ
eq S12, S13, TRUE
set I4, 0
branch FALSE
NEQ: eq I2, I3, TRUE
set I4, 0
branch FALSE
NE: ne S0, "<>", GT
set I4, 1
eq I8, 0, NNE
ne S12, S13, TRUE
set I4, 0
branch FALSE
NNE: ne I2, I3, TRUE
set I4, 0
branch FALSE
GT: ne S0, "<", LT
set I4, 1
eq I8, 0, NGT
gt S12, S13, TRUE
set I4, 0
branch FALSE
NGT: gt I2, I3, TRUE
set I4, 0
branch FALSE
LT: ne S0, ">", AND
set I4, 1
eq I8, 0, NLT
lt S12, S13, TRUE
set I4, 0
branch FALSE
NLT: lt I2, I3, TRUE
set I4, 0
branch FALSE
AND: ne S0, "AND", OR
set I4, 1 # Assume true
save S12
bsr TRUTH
restore I2
save S13
bsr TRUTH
restore I3
eq I3, 0, ANDF
eq I2, 0, ANDF
branch TRUE
ANDF: set I4, 0
branch FALSE
OR: ne S0, "OR", UNKOP
set I4, 1
save S12
bsr TRUTH
restore I2
save S13
bsr TRUTH
restore I3
eq I3, 1, TRUE
eq I2, 1, TRUE
ORF: set I4, 0
branch FALSE
UNKOP: branch DOFUNC
# Convenience labels
TRUE:
FALSE:
ENDNOP: save I4 # Convert result to string again
bsr ITOA
set S4, ""
restore S4
branch ENDOP
# Do a built-in function or multidimensional
# variable lookup
DOFUNC: save I5 # Stack's now kosher
# Pull things from the opstack down to the
# function name. You should get either
# values or commas until the function name is hit.
set I4, 0
PULLOP: bsr OPSTACKDEPTH
restore I0
eq I0, 0, ERRFUNC
bsr POPOPSTACK
restore S1
eq S1, ",", PULLOP
length I1, S1
dec I1
substr S2, S1, I1, 1 # Last char
eq S2, "!", RUNFUNC
save S1
inc I4
branch PULLOP
RUNFUNC:
length I1, S1
dec I1
substr S1, S1, 0, I1
save S1
inc I4
save I4 # Stack's proper
bsr STFUNCDISPATCH
restore S4 # The return value.
restore I5 # Depth
branch ENDOP
# The only Should Not Happen function.
ERRFUNC:print "Unexpected stack exhaustion\n"
end
ENDOP: save S4
bsr PUSHOPSTACK
branch CALCLOOP
# In a well-formed expression only the *last* think on the opstack
# is what should be returned. However because of tuples, we're going
# do de-construct the opstack back into a single value in case.
CALCFINISH:
set S0, ""
set I5, 0
CALCFINLOOP:
bsr OPSTACKDEPTH
restore I0
eq I0, 0, CALCEXIT1
bsr POPOPSTACK
inc I5
branch CALCFINLOOP
# But of course, the stack is *backwards* now.
CALCEXIT1:
save I5
bsr REVERSESTACK
set S1, ""
restore I5
CALCEXITLOOP:
eq I5, 0, CALCEXIT2
restore S1
dec I5
concat S1, S0
set S0, S1
branch CALCEXITLOOP
CALCEXIT2:
save S0
save I24
popi
pops
restore I24
ret
# And now, for something completely different
#
# Truth
# Inputs: A string on the stack
# Outputs: 0 or 1, numeric on the stack
#
# "0" False
# "" False
# Anything else true.
TRUTH: pushs
pushi
restore S0
eq S0, "0", LIE
eq S0, "", LIE
save 1
branch ENDTRUTH
LIE: save 0
ENDTRUTH:
popi
pops
ret
1.1 parrot/languages/BASIC/instructions.pasm
Index: instructions.pasm
===================================================================
# This is where all of the instructions are
# for the BASIC interpreter
#
# On the way into *EVERY ONE* of these the stack looks like
# Line Number (integer, -1 if immediate mode)
# (# tokens)
# Tokenstack
# (# entries)
# Runtime stack (gosub/return, for/next)
#
# On the way *back* just the runtime stack should be there.
# If you need to modify varaibles, see the save/restore trick for LET
#
# $Id: instructions.pasm,v 1.1 2002/04/11 01:25:59 jgoff Exp $
# $Log: instructions.pasm,v $
# Revision 1.1 2002/04/11 01:25:59 jgoff
# Adding clintp's BASIC interpreter.
#
# Revision 1.10 2002/04/09 03:14:31 Clinton
# Optimized line lookups by using I18 and I19 as a line number
# cache and pointer
#
# Revision 1.9 2002/04/08 02:37:40 Clinton
# Added conditionals and logical operators to expr and tests
#
# Revision 1.8 2002/04/06 22:57:21 Clinton
# Added multidimensional ability to INPUT and READ
#
# Revision 1.7 2002/04/06 21:25:20 Clinton
# Enhanced LET a bit
#
# Revision 1.6 2002/04/06 20:24:44 Clinton
# Don't recall
#
# Revision 1.5 2002/04/06 17:24:02 Clinton
# Before 3rd party variable decoding for LET/READ
#
# Revision 1.4 2002/04/01 22:16:54 Clinton
# Added DUMP copcode, protection for random seed
#
# Revision 1.3 2002/03/31 17:35:22 Clinton
# Added ability to cross-nest loops and subroutines
#
# Revision 1.2 2002/03/31 05:13:56 Clinton
# Id Keywords
#
#
#
I_REM: pushi
pushs
restore I0 # Line number
bsr CLEAR # Clear the token stack
restore I0 # Pull the 0
END_I_REM:
popi
pops
ret
I_END: pushi
pushs
restore I0
bsr CLEAR
restore I0
popi
pops
set I22, 1 # No errors!
ret
I_DUMP: pushi
pushs
restore I0
bsr CLEAR
restore I0
print S21
print "\n"
popi
pops
ret
# RESTORE
# (Resets read/data)
I_RESTORE:
restore I0 # Line number
bsr CLEAR
restore I0 # Empty pointer
set I26, 0
set I27, 0
END_I_RESTORE:
ret
# DATA
# (A no-op normally)
I_DATA: pushi
pushs
restore I0
bsr CLEAR
restore I0
END_I_DATA:
popi
pops
ret
# READ numvar
# READ numvar(index...)
# READ stringvar
# READ stringvar(index...)
#
I_READ: pushi
pushs
restore I0 # Line number
restore I5
restore S0 # "READ"
dec I5
save I5
save "REM" # No stopword
bsr VARDECODE
restore I3 # Type
restore S0 # Variable name
bsr CLEAR
restore I0
DO_READ_DATA:
save I26 # Current indexed line number
bsr CFETCH
restore I0 # Line Number
eq I0, -1, ERR_DATA_EXHAUSTED
restore S3 # We'll need this in a sec.
save S3
bsr TOKENIZER
bsr REVERSESTACK
restore I5
restore S1 # Line number
dec I5
restore S2 # Statement
dec I5
save I5
bsr CLEAR
restore I6 # Dummy
set I26, I0 # Line number, exactly
ne S2, "DATA", DO_READ_DATA_AGAIN
eq I5, 0, DO_READ_DATA_AGAIN # Empty data statement?
# Woo! Got the line. It's in S3
set I0, 0
save S3
save " "
save I0
bsr STRNCHR
restore I0 # First space
inc I0
save S3
save " "
save I0
bsr STRNCHR
restore I0 # Next space.
inc I0
length I1, S3
sub I1, I1, I0
substr S1, S3, I0, I1
# S1 has the DATA "data". Go evaluate. Build a "token stack"
save S1
bsr TOKENIZER
bsr REVERSESTACK
save "REM"
bsr EVAL_EXPR
restore S1
bsr CLEAR
restore I5 # Dummy
set I4, 0 # Data things seen
set I0, 0 # Start place
LOOP_DATA:
save S1 # Result
save ","
save I0
bsr STRNCHR
restore I1
eq I1, -1, GET_LAST
sub I2, I1, I0
substr S2, S1, I0, I2
ge I4, I27, GOT_DATA
set I0, I1
inc I0
inc I4
branch LOOP_DATA
GET_LAST:
length I2, S1
sub I2, I2, I0
substr S2, S1, I0, I2
ge I4, I27, GOT_DATA
branch DO_READ_DATA_AGAIN # Next line
GOT_DATA:
# So store S2 into variable S0 type I3 (N=1 A=0)
inc I4
set I27, I4
save S0 # Name
save S2 # Value
eq I3, STYPE, DATA_STR
bsr ATOI
bsr NSTORE
branch END_I_READ
DATA_STR:
bsr SSTORE
branch END_I_READ
DO_READ_DATA_AGAIN:
inc I26
set I27, 0 # Index to use, reset
branch DO_READ_DATA
END_I_READ:
save S20
save S21
save I26
save I27
popi
pops
restore I27
restore I26
restore S21
restore S20
ret
# PRINT (just a newline)
# PRINT expr (anything else)
# I6 is the trailing newline marker
I_PRINT:
pushi
pushs
set I6, 1
restore I0 # Line number
restore I5 # Depth
restore S0 # The print
dec I5
eq I5, 0, PRINTNL # Just the newline
save I5
bsr REVERSESTACK # Last arg is first
restore I5
restore S0
save S0
save I5
bsr REVERSESTACK # Put it back in order
ne S0, ";", FIGURETYPE
bsr REVERSESTACK
restore I5
dec I5
restore S0
save I5
bsr REVERSESTACK
set I6, 0
FIGURETYPE:
# What we have here is an expression.
save "" # No stopwords
bsr EVAL_EXPR
restore S0
print S0
bsr CLEAR
restore I0 # dummy
PRINTNL:
eq I6, 0, I_PRINT_EXIT
print "\n"
I_PRINT_EXIT:
save I24
popi
pops
restore I24
ret
# LET NUMVAR=EXPR
# LET NUMVAR(EXPR[,EXPR]...)=EXPR
# LET STRINGVAR$=EXPR
# LET STRINGVAR$(EXPR[,EXPR]...)=EXPR
#
I_LET: pushi
pushs
restore I0 # Line number
restore I5 # Depth
restore S0 # Keyword "LET"
dec I5
save I5
save "=" # Don't pull this!
bsr VARDECODE
restore I3 # Type
restore S1 # Name
restore I5
restore S2 # The "="
dec I5
ne S2, "=", ERR_I_LET
save I5
save "REM"
bsr EVAL_EXPR
restore S0
eq I3, NTYPE, LETNUM
save S1
save S0
bsr SSTORE
branch END_I_LET
LETNUM: save S1
save S0
bsr ATOI
bsr NSTORE
END_I_LET:
bsr CLEAR # Clear the token stack
restore I0 # Pull the 0
save S20
save S21
save I24
popi
pops
restore I24
restore S21
restore S20
ret
ERR_I_LET:
# Recover
save I5
bsr CLEAR
restore I5
branch SYNTAX_ERROR
# DIM STRINGVAR(EXPR)
# Dimension is now a no-op.
I_DIM: pushi
pushs
restore I0 # Line number
bsr CLEAR # Clear the token stack
restore I0 # Pull the 0
popi
pops
ret
# GOTO EXPR
# GO TO EXPR
I_GOTO: pushi
pushs
restore I0 # Line Number
restore I5 # Depth
restore S0 # Keyword "GO" or "GOTO"
dec I5
eq S0, "GOTO", I_NOTGO_TO
restore S0 # Hope this is a "TO" :)
dec I5
I_NOTGO_TO:
save I5
save "" # Stopwords
bsr EVAL_EXPR
bsr ATOI
restore I23 # PROGRAM COUNTER. :)
bsr CLEAR
restore I0
END_I_GOTO:
save I23
popi
pops
restore I23
ret
# IF EXPR COND EXPR THEN STATEMENT
# (This should be a total mindfuck)
I_IF: pushi
pushs
restore I6 # Line #
restore I5 # Depth
set I0, 0
restore S0 # "IF"
dec I5
save I5
save "THEN"
bsr EVAL_EXPR # True or false?
restore S0 # The return value...
restore I5
restore S1 # THEN
dec I5
ne S1, "THEN", ERR_SYN_CLEAR
save I5
save S0
bsr TRUTH # Change return value to truth
restore I0 # Truth value
eq I0, 1, IF_WORKED
# The stack *is* kosher at this point
IF_FAILED:
bsr CLEAR
restore I0 # BAIL!
branch END_I_IF # The assertion failed
IF_WORKED:
# The idea is, to throw the runtime into 1-line mode
# temporarily. We've got the next statement tokenized
# on the stack, but we've got to jump back into the RUNLINE
# logic like nothing happened. :)
# This took me forever to get right. Be careful here.
eq I20, 0, IF_IMM
restore I5 # Stack depth
save I6 # Fake my own line number
bsr ITOA
inc I5
save I5
IF_IMM:
save I23
save I20
save I24
popi
pops
restore I24
restore I20
restore I23
pushi # To emulate the one at the beginning of RUNLINE
pushs
bsr RUN_INSERT
restore I0 # Status of the statement called
eq I0, 0, IF_BAIL
branch ERR_IF
IF_BAIL:
ret
END_I_IF:
save I24
popi
pops
restore I24
ret
IFERR: print "FATAL: Unexpected comparison operator mismatch\n"
end
# All of these instructions deal with the runtime stack.
# The runtime stack lives *just below* the stack used by the
# program counter, tokenizer, etc..
# Format (top to bottom, all strings)
#
# "GOS" "FOR"
# LINECALLED LINECALLED
# "" TESTVAR
# "" FINAL
# "" STEP
# With FOR you *always* get one loop for free
I_FOR: pushi
pushs
restore I10 # My line number.
restore I5
restore S1 # "FOR"
restore S0 # Variable Name
restore S1 # "="
sub I5, I5, 3
ne S1, "=", ERR_SYN_CLEAR
save I5
save "TO" # Stopword
bsr EVAL_EXPR
bsr ATOI
restore I0
restore I5
save I5
eq I5, 0, ERR_SYN_CLEAR # If the "TO" is missing
save S0 # Variable name
save I0 # Begin value
bsr NSTORE
restore I5
restore S1 # "TO"
dec I5
set S2, "" # Accumulate
FORFINAL:
le I5, 0, NOSTEPKEY
restore S1
eq S1, "STEP", PUTBACKSTEP
dec I5
concat S2, S1
concat S2, " "
branch FORFINAL
NOSTEPKEY:
save I5
branch NOARGSFOR
PUTBACKSTEP:
save "STEP"
save I5
NOARGSFOR:
# Okay, what's on the stack now? A step?
restore I5
save I5
set I3, 1 # Assume step 1
eq I5, 0, NOSTEP
restore I5
restore S1
dec I5
ne S1, "STEP", ERR_SYN_CLEAR # SNH
save I5
save ""
bsr EVAL_EXPR
restore S31
save S31
bsr ATOI
restore I3 # The step
eq I3, 0, FOR_SYNTAX1
NOSTEP:
bsr CLEAR # clear instruction stack
restore I1 # dummy...
# Meddle with runtime stack
restore I5 # The old depth
save I3
bsr ITOA # Step
inc I5
save S2 # Final (this is an expression!)
inc I5
save S0 # Var
inc I5
inc I10
save I10
bsr ITOA # Line number +1
inc I5
save "FOR"
inc I5
save I5
END_I_FOR:
save S20
save I24
popi
pops
restore I24
restore S20
ret
FOR_SYNTAX1:
print "FOR cannot have Step of 0\n"
branch SYNTAX_ERROR
# NEXT
#
I_NEXT: pushi
pushs
restore I10 # My Line #
restore I5
restore S0 # "NEXT"
dec I5
restore S0 # Variable Name
save S0
bsr NFETCH
restore I0 # Current value
dec I5
save I5 # Clear rest of INSTRUCTION stack
bsr CLEAR
restore I5 # dummy
save "FOR"
save S0
bsr STACKSEARCH
# Okay, now dip into the runtime stack
restore I5
le I5, 0, ERR_I_UNDERFLOW
# Remove 5!
restore S7
dec I5
ne S7, "FOR", ERR_I_NEXT_MS
bsr ATOI
restore I11 # Potential new line #
dec I5
restore S1 # Variable expected (sanity only)
dec I5
ne S1, S0, ERR_I_NEXT_CROSS
restore S8 # Final expression
save S8
bsr TOKENIZER # With the ending-expression
bsr REVERSESTACK
save "" # No stopwords
bsr EVAL_EXPR
bsr ATOI
restore I2
dec I5
bsr CLEAR
restore I1 # dummy
bsr ATOI
restore I3 # Step
dec I5
# FOR LOOP CONTINUE (logic used by NEXT)
# I3 - step
# I2 - end value
# I0 - current value
# I11 - branch target (if succeed)
#
# STEP > 0 IF I0 > I2 BAIL
# IF I0 <= I2 CONTINUE
# STEP < 0 IF I0 < I2 BAIL
# IF I0 >= I2 CONTINUE
add I0, I0, I3
save S0
save I0
bsr NSTORE
lt I3, 0, FOR_BACK
gt I0, I2, GO_FORWARD
branch GO_BACK
FOR_BACK:
lt I0, I2, GO_FORWARD
branch GO_BACK
GO_BACK:
save I3 # Step
bsr ITOA
save S8 # Final Expr
save S0 # Var name
save I11
bsr ITOA # Line number
save "FOR"
add I5, I5, 5
save I5 # Stack's back to kosher
set I23, I11 # New line #
save I23
save S20
save I24
popi
pops
restore I24
restore S20
restore I23
ret
GO_FORWARD:
save I5 # Put the runtime stack back (forget the FOR)
#save S20 # Uncomment to change the after-loop value of the index
save I24
popi
pops
restore I24
#restore S20
ret # Go to next instruction normally
# GOSUB EXPR
# Yes, it's a computed GOSUB. :)
I_GOSUB:
pushi
pushs
restore I10 # Line number
restore I5
restore S0 # GOSUB
dec I5
save I5
save ""
bsr EVAL_EXPR
bsr ATOI
restore I23 # Program Counter
bsr CLEAR
restore I0 # dummy
# Build the return information
inc I10 # Return to my followers
restore I5
save ""
save ""
save ""
save I10
bsr ITOA # Return target
save "GOS"
add I5, I5, 5
save I5
save I23
popi
pops
restore I23
ret
# RETURN
I_RETURN:
pushi
pushs
restore I10 # Line number
bsr CLEAR
restore I0 # dummy
save "GOS"
save ""
bsr STACKSEARCH # Pitches unneeded things.
restore I5
le I5, 0, ERR_I_UNDERFLOW
restore S0
dec I5
ne S0, "GOS", ERR_I_NEXT_MS
bsr ATOI
restore I23
restore S0
restore S0
restore S0
sub I5, I5, 4
save I5
save I23
popi
pops
restore I23
ret
#LIST
I_LIST:
pushi
pushs
restore I10 # Not important
restore I5
restore S0 # "LIST"
dec I5
set I2, 0 # Start
set I3, -1 # End
eq I5, 0, DO_I_LIST
save I5
save "-"
bsr EVAL_EXPR
bsr ATOI
restore I2
restore I5
eq I5, 0, LIST_ONE_LINE # All tokens used.
branch LIST_RANGE
LIST_ONE_LINE:
set I3, I2
branch DO_I_LIST
LIST_RANGE:
restore S0 # -
dec I5
save I5
save ""
bsr EVAL_EXPR
bsr ATOI
restore I3
DO_I_LIST:
set I0, I2
LIST_LOOP:
save I0
bsr CFETCH
restore I0
eq I0, -1, END_LIST
restore S0
print S0
print "\n"
inc I0
eq I3, -1 LIST_LOOP # Go to the end
gt I0, I3, END_LIST
branch LIST_LOOP
END_LIST:
popi
pops
ret
# RUN
# Note: there's no localizations here.
I_RUN: restore I10 # Line number
bsr CLEAR
restore I0 # Dummy
set I20, 1 # Runline mode
set I23, -1 # Program Counter
set S20, "#" # Clear numerics
set S21, "#" # Clear Alpha
set I26, -1 # Reset READ/DATA line number
set I27, 0 # And thingy.
set I18, 0 # Reset line cache
set I19, 0
CODELOOP:
save I23
bsr CFETCH
restore I23
eq I23, -1, END
restore S0
save S0
inc I23
bsr RUNLINE
restore I1 # Status
ne I1, 0, ERROR
branch CODELOOP
ERROR: # Okay, it's not actually an error branch anymore.
END: set I20, 0 # Normal mode
ret
# NEW
I_NEW: pushi
pushs
restore I10
bsr CLEAR
restore I10
set S22, "#" # Initialize Codespace
save S22
popi
pops
restore S22
ret
# LOAD
# This isn't particularly robust until the I/O gets
# more rounded out. It's particularly strange becase there's
# no line-based I/O from filehandles. Instead buffer it all and
# split based on \n's
I_LOAD:
pushi
pushs
restore I10 # Line number
restore I5
restore S0 # "NEW"
dec I5
eq I5, 0, SYNTAX_ERROR
restore S0
dec I5
save I5
bsr CLEAR
restore I5 # dummy
concat S0, ".bas"
print "LOADING "
print S0
print "..."
open P0, S0, "<"
ne I0, 0, ERR_IO
set S1, "" # Accumulator
LOAD_READ:
read S0, P0, 256
length I0, S0
le I0, 0, LOAD_FIN
concat S1, S0
branch LOAD_READ
# Break into lines
LOAD_FIN:
set I0, 0
set I5, 0
MAKELINES:
save S1
save "\n"
save I0
bsr STRNCHR
restore I1
eq I1, -1, ENDLINES
sub I2, I1, I0
print ""
#print "<makelinesubstr>"
substr S2, S1, I0, I2
#print "</makelinesubstr>"
save S2 # The line
inc I5
bsr STRIPSPACE # Just leave it...
FIN_LINES:
set I0, I1
inc I0
branch MAKELINES
ENDLINES:
close P0
save I5
bsr CENDLOAD
print "DONE\n"
ret
# INPUT numvar
# INPUT stringvar
I_INPUT:
pushi
pushs
restore I10 # Line number
restore I5
restore S0 # "INPUT"
dec I5
eq I5, 0, SYNTAX_ERROR
save I5
save "REM"
bsr VARDECODE
restore I3 # Type
restore S0 # Variable
bsr CLEAR
restore I0 # Dummy
set S3, ""
read S3, 256
clone S4, S3
set S5, S4
save S5
bsr STRIPSPACE
restore S5
eq I3, STYPE, INPSTRING
save S0
save S5
bsr ATOI
bsr NSTORE
branch ENDINPUT
INPSTRING:
savec S0
savec S5
bsr SSTORE
branch ENDINPUT
ENDINPUT:
save S20
save S21
popi
pops
restore S21
restore S20
ret
# Runtime stack mgmt.
# Put two things on the stack. A type FOR/GOS and
# a marker (variable name/""). This will search down
# through the stack.
# Called by "RETURN" and "NEXT"
STACKSEARCH:
pushi
pushs
restore S0 # Marker
restore S1 # TypeA
KEEPLOOKING:
restore I5 # Stack depth
eq I5, 0, ENDSEARCH
restore S2 # Type
restore S3 # Line #
restore S4 # Marker (FOR)
restore S5 # Expression (FOR)
restore S6 # Step (FOR)
sub I5, I5, 5
save I5
ne S2, S1, KEEPLOOKING # Type mismatch
ne S0, S4, KEEPLOOKING # Marker mismatch
PUTBACK:
restore I5
save S6
save S5
save S4
save S3
save S2
add I5, I5, 5
ENDSEARCH:
save I5
popi
pops
ret
# Error messages
#
ERR_IO:
print "I/O Error "
err S0
print S0
print "\n"
branch ALL_ERR
ERR_I_NEXT_MS: # This is a Should Not Happen error now.
save I5
bsr CLEAR
restore I0
save 0 # Initialize a new runtime stack
print "Unexpected FOR/GOS on stack "
branch ALL_ERR
ERR_I_NEXT_CROSS:
save I5
bsr CLEAR
restore I0
save 0 # Initialize a new runtime stack
print "Crossed FOR/NEXT values "
branch ALL_ERR
ERR_I_UNDERFLOW:
save 0 # Initialize a new runtime stack
print "GOSUB/FOR stack underflow "
branch ALL_ERR
SYNTAX_ERROR:
print "Syntax error "
branch ALL_ERR
ERR_SYN_CLEAR:
save I5
bsr CLEAR
restore I0
branch SYNTAX_ERROR
ERR_I_DIM2:
print "Dimension size <= 0 "
bsr CLEAR
restore I0
branch ALL_ERR
ERR_DATA_EXHAUSTED:
print "DATA EXHAUSTED AT READ "
branch ALL_ERR
ERR_IF:
print "Error in IF statement at line "
dec I23
save I23
bsr ITOA
restore S31
print S31
print "\n"
set I22, 1
ret
ALL_ERR:
dec I23
print " at line "
save I23
bsr ITOA
restore S31 # Convert for puts
print S31
print "\n"
set I22, 1 # Stop please
save I22
popi
pops
restore I22
ret
1.1 parrot/languages/BASIC/sample2.bas
Index: sample2.bas
===================================================================
10 GOSUB 100
20 GOSUB 300
30 GOSUB 400
90 END
100 REM
101 REM Exercise the expression evaluator
102 REM
110 PRINT "Numeric and expression evaluation."
115 PRINT "Should be 5: ";
120 PRINT 5+2*3-6
125 PRINT "Should be -3: ";
130 PRINT 15/3+((3*2+2-1+1)*-1)
135 PRINT "Should be a 4-item list: ";
140 PRINT 5,"HELLO WORLD",67,-1
145 PRINT "Functions, first the alphabet: ";
150 FOR I=65 TO 90
155 PRINT CHR(I);
160 NEXT I
161 PRINT
163 PRINT "String funcs, BROAD: ";
165 DIM SAMPLE$(30)
170 LET SAMPLE$="EMERGENCY BROADCAST"
175 PRINT MID(SAMPLE$,11,5)
180 PRINT
190 RETURN
300 REM
301 REM Exercise the READ/DATA/RESTORE functions
302 REM
305 PRINT "Testing READ/DATA Should see series 0..10 then 0..10"
310 FOR I=0 TO 10
315 READ F
320 PRINT F;
330 PRINT " ";
340 NEXT I
350 RESTORE
355 PRINT
360 FOR I=0 TO 10
365 READ H
370 PRINT H;
375 PRINT " ";
379 NEXT I
380 PRINT
381 DIM A$(20)
392 PRINT "And string read (thats all folks):";
383 READ A$
384 PRINT A$
385 RETURN
390 DATA 0, 1, 2, 3, 4, 5
395 DATA 6, 7, 8, 9, 10, "All Done w READ/DATA"
400 REM
401 REM Demonstrate FOR/NEXT looping
402 REM
405 PRINT "First count by 2s, then backwards from 10, then nested 0-3"
410 FOR I=0 TO 10 STEP 2
412 PRINT I;
413 PRINT " ";
415 NEXT I
420 PRINT
425 FOR I=10 TO 0 STEP -1
430 PRINT I;
435 PRINT " ";
440 NEXT I
445 PRINT
450 FOR I=0 TO 3
455 FOR J=0 TO 3
460 PRINT I;
462 PRINT " ";
470 PRINT J;
472 PRINT " ";
475 NEXT J
480 PRINT
485 NEXT I
490 RETURN
1.1 parrot/languages/BASIC/sample3.bas
Index: sample3.bas
===================================================================
10 GOSUB 100
20 REM GOSUB 500
90 END
100 REM
101 REM Conditionals and stuff
102 REM
104 LET I=I+1
105 PRINT "Looping...";
106 PRINT I
110 IF I=5 THEN GOTO 150
120 GOTO 104
150 PRINT "Done"
160 RETURN
500 REM
501 REM Arrays and random numbers
502 REM
505 PRINT "Distribution of 100 random numbers 1-10:"
510 FOR I=0 TO 99
520 LET NUMBER=RND(10)
530 LET ARR(NUMBER)=ARR(NUMBER)+1
540 NEXT I
545 FOR I=0 TO 9
546 PRINT "The number ";
547 PRINT I;
548 PRINT " was seen ";
560 PRINT ARR(I);
565 PRINT " times"
570 NEXT I
590 RETURN
1.1 parrot/languages/BASIC/sample4.bas
Index: sample4.bas
===================================================================
10 GOSUB 100
20 GOSUB 300
99 END
100 REM
101 REM Test strings and stuff
102 REM
105 PRINT "String test. My name and then a Tic-Tac-Toe board"
110 LET A$="Clinton Pierce"
120 PRINT "Parrot BASIC by: ";
130 PRINT A$
140 FOR I=0 TO 2
150 FOR J=0 TO 2
155 READ R$
157 LET T$(I,J)=R$
160 NEXT J
170 NEXT I
190 DATA "X","O"," "
200 DATA "X","X","O"
210 DATA "O","O","X"
220 FOR I=0 TO 2
230 FOR J=0 TO 2
240 PRINT T$(I,J);
250 PRINT " ";
260 NEXT J
265 PRINT
270 NEXT I
280 RETURN
300 REM
301 REM String Concatenation
302 REM
305 DUMP
310 LET A$="HELLO "
315 DUMP
320 LET B$="WORLD"
340 LET C$=A$+B$
350 PRINT "Standard greeting: ";
360 PRINT C$
370 RETURN
1.1 parrot/languages/BASIC/stackops.pasm
Index: stackops.pasm
===================================================================
# Stack Library
# This'll get a whole lot cleaner when I can tell the
# depth of the stack automagically
#
# $Id: stackops.pasm,v 1.1 2002/04/11 01:25:59 jgoff Exp $
# $Log: stackops.pasm,v $
# Revision 1.1 2002/04/11 01:25:59 jgoff
# Adding clintp's BASIC interpreter.
#
# Revision 1.3 2002/03/31 05:15:31 Clinton
# Adjusted
#
# Revision 1.2 2002/03/31 05:13:28 Clinton
# Id Keywords
#
# peek -- return whatever string is on the stack
# Inputs: the offset on the stack
# Outputs: the string
# Non-Destructive!
# Does *not* test for bounds conditions
PEEK: pushi
restore I0
set I3, I0
inc I0
set I2 0
PLOOP: ge I2, I3, POL
rotate_up I0
inc I2
branch PLOOP
POL:
restore S0
save S0
eq I0, 0, EOP
rotate_up I0
EOP: save S0
popi
ret
# REPLACE -- replace thing at stack position X
# Inputs: the offset to remove
# the string to leave in its place
# Outputs: The string removed
# Note: Almost *identical* to PEEK above
# Does *not* test for bounds conditions
REPLACE: pushi
pushs
restore S1
restore I0
set I3, I0
inc I0
set I2, 0
RLOOP: ge I2, I3, ROL
rotate_up I0
inc I2
branch RLOOP
ROL: restore S0
save S1
eq I0, 0, ENDOFREPLACE
rotate_up I0
ENDOFREPLACE:
save S0
popi
pops
ret
# swap -- swap the position of two strings on the stack
# Inputs: Offsets of the two things on the stack
# Outputs: None.
# Does *not* test for bounds conditions
SWAP: pushi
pushs
restore I0
restore I1
save I0
save "-" # Just a dummy
bsr REPLACE
restore S0
save I1
save S0
bsr REPLACE
restore S1
save I0
save S1
bsr REPLACE
restore S1 # dummy
popi
pops
ret
# Reverse the stack
# Inputs: Stack depth on top of the stack
# Outputs: Stack depth on top of the stack
REVERSESTACK:
pushi
restore I5
set I0, I5
REVSHIFT:
eq I0, 0, REVERSEEND
rotate_up I0
dec I0
branch REVSHIFT
REVERSEEND:
save I5
popi
ret
# Clear the stack
# Inputs: Stack depth on top of the stack
# Outputs: 0 on top of the stack
CLEAR: pushi
pushs
restore I5
CLEARL: eq I5, 0, CLEAREND
restore S0
dec I5
branch CLEARL
CLEAREND:
save 0
popi
pops
ret
# SORTSTACK
# Inputs: A well-formed stack
# Outputs: Another well-formed stack
# Ported from suggestions at http://www.perlmonks.org/index.pl?node_id=153974
# as an improvement over the bubble sort.
SORTSTACK:
pushi
pushs
# Assume that rotate_up as defined in the original problem
# statement has been defined.
restore I5 # local $len = pop(@stack);
set I6, I5 # local $bum = $len;
# local ($x, $y, $limit);
SORTMORE:
le I6,1,ENDSORT # while ($bum > 1) {
set I7, I6 # $limit = $bum;
SHUFFLE:
dec I7
eq I7, 0, ALMOSTDONE # while (--$limit) {
restore S2 # $x = pop(@stack);
restore S3 # $y = pop(@stack);
le S2, S3, SORTSWAP # if ($x gt $y) {
save S2 # push(@stack, $x);
save S3 # push(@stack, $y);
branch ROT # }
SORTSWAP: # else {
save S3 # push(@stack, $y);
save S2 # push(@stack, $x); }
ROT:
rotate_up I6 # rotate_up($bum);
branch SHUFFLE # }
ALMOSTDONE: # At end of the $limit loop, top element is the max, and
# top+1 to end is semi-sorted. One more rotate_up()
# is needed before moving the floor up one notch.
rotate_up I6 # rotate_up($bum);
dec I6 # $bum--; }
branch SORTMORE
ENDSORT:
save I5
popi
pops
ret
1.1 parrot/languages/BASIC/tokenize.pasm
Index: tokenize.pasm
===================================================================
# tokenizer
# Input: string to be parsed on the stack (will be removed)
# Output: stack contains number of tokens first,
# then the tokens as seen right to left
# ** leftmost on bottom **
# Quotes (single or double) are *preserved* so that
# Foo "bar hlaghalg"
# is two tokens, and the second is "bar hlaghalg"
# Consecutive non-alphabetic characters are each considered a token
#
# $Id: tokenize.pasm,v 1.1 2002/04/11 01:25:59 jgoff Exp $
# $Log: tokenize.pasm,v $
# Revision 1.1 2002/04/11 01:25:59 jgoff
# Adding clintp's BASIC interpreter.
#
# Revision 1.2 2002/03/31 05:13:44 Clinton
# Id Keywords
#
#
TOKENIZER:
pushi
pushs
set I3, 0 # Inquote
set I4, 0 # ALPHA
set S0, "" # Playground
set S2, ""
restore S2 # String to tokenize
set I5, 0 # Stack pointer
TOKLOOP: length I0, S2
eq I0, 0, ENDTOK
set S1, ""
substr S1, S2, 0, 1
dec I0
substr S2, S2, 1, I0
eq S1, "'", QUOTE
eq S1, '"', QUOTE
branch CKQUOTED
QUOTE: ne I3, 0, EOTOK
length I0,S0
eq I0, 0, FINQUOT
save S0
inc I5
FINQUOT:set I3, 1
set S0, S1
branch TOKLOOP
EOTOK: set I3, 0
concat S0, S1
save S0
inc I5
set S0, ""
branch TOKLOOP
CKQUOTED:
eq I3, 0, NOTQUOTED
concat S0, S1
branch TOKLOOP
NOTQUOTED:
save S1
bsr ISWHITE
restore I2
ne I2, 1, NOTSPACE # Spaces will end a token
length I0, S0
eq I0, 0, TOKLOOP
save S0
inc I5
set S0, ""
branch TOKLOOP
NOTSPACE:
save S1
bsr ISALPHA
restore I0
length I1, S0
ne I1, 0, NOTEMPTY
set S0, S1
set I4, I0
branch TOKLOOP
NOTEMPTY:
eq I4, 0, TOKCHANGED
ne I0, I4, TOKCHANGED
concat S0, S1
branch TOKLOOP
TOKCHANGED:
save S0
inc I5
set S0, S1
set I4, I0
branch TOKLOOP
ENDTOK: length I0, S0
eq I0, 0, TOKBAIL
save S0
inc I5
TOKBAIL:save I5
popi
pops
ret
1.1 parrot/languages/BASIC/wumpus.bas
Index: wumpus.bas
===================================================================
1 REM Taken from David Ahl's 101 BASIC Games reproduced in article
2 REM (available on Google) 9207071854.AA21847@thep.lu.se
3 REM Ported to Parrot BASIC by Clinton Pierce.
4 REM License status: Unknown
5 REM *** HUNT THE WUMPUS ***
11 DIM I$(20)
15 PRINT "INSTRUCTIONS (Y-N)";
20 INPUT I$
25 IF I$="N" THEN GOTO 35
30 GOSUB 375
35 GOTO 80
80 REM *** SET UP CAVE (DODECAHEDRAL NODE LIST) ***
90 FOR J=1 TO 20
95 FOR K=1 TO 3
100 READ S(J,K)
105 NEXT K
110 NEXT J
115 DATA 2,5,8,1,3,10,2,4,12,3,5,14,1,4,6
120 DATA 5,7,15,6,8,17,1,7,9,8,10,18,2,9,11
125 DATA 10,12,19,3,11,13,12,14,20,4,13,15,6,14,16
130 DATA 15,17,20,7,16,18,9,17,19,11,18,20,13,16,19
150 REM *** LOCATE L ARRAY ITEMS ***
155 REM *** 1-YOU, 2-WUMPUS, 3&4-PITS, 5&6-BATS ***
170 PRINT "SETTING UP MAZE. PLEASE WAIT."
171 FOR J=1 TO 6
175 LET L(J)=RND(20)+1
180 LET M(J)=L(J)
185 NEXT J
190 REM *** CHECK FOR CROSSOVERS (IE L(1)=L(2), ETC) ***
195 FOR J=1 TO 6
200 FOR K=1 TO 6
205 IF J=K THEN GOTO 215
210 IF L(J)=L(K) THEN GOTO 171
215 NEXT K
220 NEXT J
225 REM *** SET NO. OF ARROWS ***
230 LET A=5
235 LET L=L(1)
240 REM *** RUN THE GAME ***
245 PRINT "HUNT THE WUMPUS"
250 REM *** HAZARD WARNING AND LOCATION ***
255 GOSUB 585
260 REM *** MOVE OR SHOOT ***
265 GOSUB 670
271 IF O=1 THEN GOTO 280
272 IF O=2 THEN GOTO 300
273 REM 270 ON O GOTO 280,300
275 REM *** SHOOT ***
280 GOSUB 715
285 IF F=0 THEN GOTO 255
290 GOTO 310
295 REM *** MOVE ***
300 GOSUB 975
305 IF F=0 THEN GOTO 255
310 IF F>0 THEN GOTO 335
315 REM *** LOSE ***
320 PRINT "HA HA HA - YOU LOSE!"
325 GOTO 340
330 REM *** MOVE ***
335 PRINT "HEE HEE HEE - THE WUMPUS`LL GET YOU NEXT TIME!!"
340 FOR J=1 TO 6
345 LET L(J)=M(J)
350 NEXT J
355 PRINT "SAME SETUP (Y-N)";
360 INPUT I$
365 IF I$ <> "Y" THEN GOTO 170
370 GOTO 230
375 REM *** INSTRUCTIONS ***
380 PRINT "WELCOME TO HUNT THE WUMPUS"
385 PRINT " THE WUMPUS LIVES IN A CAVE OF 20 ROOMS. EACH ROOM"
390 PRINT "HAS 3 TUNNELS LEADING TO OTHER ROOMS. (LOOK AT A"
395 PRINT "DODECAHEDRON TO SEE HOW THIS WORKS-IF YOU DONT KNOW"
400 PRINT "WHAT A DODECAHEDRON IS, ASK SOMEONE)"
405 PRINT
410 PRINT " HAZARDS:"
415 PRINT " BOTTOMLESS PITS - TWO ROOMS HAVE BOTTOMLESS PITS IN THEM"
420 PRINT " IF YOU GO THERE, YOU FALL INTO THE PIT (& LOSE!)"
425 PRINT " SUPER BATS - TWO OTHER ROOMS HAVE SUPER BATS. IF YOU"
430 PRINT " GO THERE, A BAT GRABS YOU AND TAKES YOU TO SOME OTHER"
435 PRINT " ROOM AT RANDOM. (WHICH MAY BE TROUBLESOME)"
439 PRINT "TYPE AN I THEN RETURN ";
440 INPUT W9
445 PRINT " WUMPUS:"
450 PRINT " THE WUMPUS IS NOT BOTHERED BY HAZARDS (HE HAS SUCKER"
455 PRINT " FEET AND IS TOO BIG FOR A BAT TOO LIFT). USUALLY"
460 PRINT " HE IS ASLEEP. TWO THINGS WAKE HIM UP:YOU SHOOTING AN"
465 PRINT " OR YOU ENTERING HIS ROOM."
470 PRINT " IF THE WUMPUS WAKES HE MOVES (P=.75) ONE ROOM"
475 PRINT " OR STAYS STILL (P=.25). AFTER THAT, IF HE IS WHERE YOU"
480 PRINT " ARE, HE EATS YOU UP AND YOU LOSE!"
485 PRINT
490 PRINT " YOU:"
495 PRINT " EACH TURN YOU MAY MOVE OR SHOOT A CROOKED ARROW"
500 PRINT " MOVING: YOU CAN MOVE ONE ROOM (THRU ONE TUNNEL)"
505 PRINT " ARROWS: YOU HAVE 5 ARROWS. YOU LOSE WHEN YOU RUN OUT"
510 PRINT " EACH ARROW CAN GO FROM 1 TO 5 ROOMS. YOU AIM BY TELLIN"
515 PRINT " THE COMPUTER THE ROOM#S YOU WANT THE ARROW TO GO TO."
520 PRINT " IF THE ARROW CANT GO THAT WAY (IF NO TUNNEL) IT MOVES"
525 PRINT " AT RANDOM TO THE NEXT ROOM."
530 PRINT " IF THE ARROW HITS THE WUMPUS, YOU WIN."
535 PRINT " IF THE ARROW YOU, YOU LOSE."
539 PRINT "TYPE AN E THEN RETURN ";
540 INPUT W9
545 PRINT " WARNINGS:"
550 PRINT " WHEN YOU ARE ONE ROOM AWAY FROM A WUMPUS OR HAZARD,"
555 PRINT " THE COMPUTER SAYS:"
560 PRINT " WUMPUS: I SMELL A WUMPUS"
565 PRINT " BAT : BATS NEARBY"
570 PRINT " PIT : I FEEL A DRAFT"
575 PRINT
580 RETURN
585 REM *** PRINT LOCATION & HAZARD WARNINGS ***
590 PRINT
595 FOR J=2 TO 6
600 FOR K=1 TO 3
605 IF S(L(1),K) <> L(J) THEN GOTO 640
609 REM 610 ON J-1 GOTO 615,625,625,635,635
610 IF J-1=1 THEN GOTO 615
611 IF J-1=2 THEN GOTO 625
612 IF J-1=3 THEN GOTO 625
613 IF J-1=4 THEN GOTO 635
614 IF J-1=5 THEN GOTO 635
615 PRINT "I SMELL A WUMPUS!";
620 GOTO 640
625 PRINT "I FEEL A DRAFT"
630 GOTO 640
635 PRINT "BATS NEARBY!"
640 NEXT K
645 NEXT J
650 PRINT "YOU ARE IN ROOM ";
652 PRINT L(1)
655 PRINT "TUNNELS LEAD TO ";
656 PRINT S(L,1);
657 PRINT " ";
658 PRINT S(L,2);
659 PRINT " ";
660 PRINT S(L,3)
661 PRINT
665 RETURN
670 REM *** CHOOSE OPTION ***
675 PRINT "SHOOT OR MOVE (S-M) ";
680 INPUT I$
685 IF I$ <> "S" THEN GOTO 700
690 LET O=1
695 RETURN
700 IF I$ <> "M" THEN GOTO 675
705 LET O=2
710 RETURN
715 REM *** ARROW ROUTINE ***
720 LET F=0
725 REM *** PATH OF ARROW ***
735 PRINT "NO. OF ROOMS (1-5)";
740 INPUT J9
745 IF J9<1 THEN GOTO 735
750 IF J9>5 THEN GOTO 735
755 FOR K=1 TO J9
760 PRINT "ROOM #";
765 INPUT P(K)
770 IF K<=2 THEN GOTO 790
775 IF P(K) <> P(K-2) THEN GOTO 790
780 PRINT "ARROWS ARENT THAT CROOKED - TRY ANOTHER ROOM"
785 GOTO 760
790 NEXT K
795 REM *** SHOOT ARROW ***
800 LET L=L(1)
805 FOR K=1 TO J9
810 FOR K1=1 TO 3
815 IF S(L,K1)=P(K) THEN GOTO 895
820 NEXT K1
825 REM *** NO TUNNEL FOR ARROW ***
830 LET L=S(L,RND(3)+1)
835 GOTO 900
840 NEXT K
845 PRINT "MISSED"
850 LET L=L(1)
855 REM *** MOVE WUMPUS ***
860 GOSUB 935
865 REM *** AMMO CHECK ***
870 LET A=A-1
875 IF A>0 THEN GOTO 885
880 LET F=-1
885 RETURN
890 REM *** SEE IF ARROW IS AT L(1) OR AT L(2)
895 LET L=P(K)
900 IF L <> L(2) THEN GOTO 920
905 PRINT "AHA! YOU GOT THE WUMPUS!"
910 LET F=1
915 RETURN
920 IF L <> L(1) THEN GOTO 840
925 PRINT "OUCH! ARROW GOT YOU!"
930 GOTO 880
935 REM *** MOVE WUMPUS ROUTINE ***
940 LET K=RND(4)+1
945 IF K=4 THEN GOTO 955
950 LET L(2)=S(L(2),K)
955 IF L(2) <> L THEN GOTO 970
960 PRINT "TSK TSK TSK - WUMPUS GOT YOU!"
965 LET F=-1
970 RETURN
975 REM *** MOVE ROUTINE ***
980 LET F=0
985 PRINT "WHERE TO ";
990 INPUT L
995 IF L<1 THEN GOTO 985
1000 IF L>20 THEN GOTO 985
1002 REM PRINT "Wanted ",L
1005 FOR K=1 TO 3
1010 REM *** CHECK IF LEGAL MOVE ***
1017 IF S(L(1),K)=L THEN GOTO 1045
1020 NEXT K
1025 IF L=L(1) THEN GOTO 1045
1030 PRINT "NOT POSSIBLE -";
1035 GOTO 985
1040 REM *** CHECK FOR HAZARDS ***
1045 LET L(1)=L
1050 REM *** WUMPUS ***
1055 IF L <> L(2) THEN GOTO 1090
1060 PRINT "... OOPS! BUMPED A WUMPUS!"
1065 REM *** MOVE WUMPUS ***
1070 GOSUB 940
1075 IF F=0 THEN GOTO 1090
1080 RETURN
1085 REM *** PIT ***
1090 IF L=L(3) THEN GOTO 1100
1095 IF L <> L(4) THEN GOTO 1120
1100 PRINT "YYYYIIIIEEEE . . . FELL IN PIT"
1105 LET F=-1
1110 RETURN
1115 REM *** BATS ***
1120 IF L=L(5) THEN GOTO 1130
1125 IF L <> L(6) THEN GOTO 1145
1130 PRINT "ZAP--SUPER BAT SNATCH! ELSEWHEREVILLE FOR YOU!"
1135 LET L=RND(20)+1
1140 GOTO 1045
1145 RETURN
1150 END
-
cvs commit: parrot/languages/BASIC README.BASIC alpha.pasm basic.pasm basic.pl basicvar.pasm dumpstack.pasm expr.pasm instructions.pasm sample2.bas sample3.bas sample4.bas stackops.pasm tokenize.pasm wumpus.bas
by jgoff