mirror of
https://github.com/kanaka/mal.git
synced 2024-09-11 13:55:55 +03:00
Merge branch 'basic'
This commit is contained in:
commit
1b03073347
12
.gitignore
vendored
12
.gitignore
vendored
@ -106,3 +106,15 @@ vb/*.dll
|
||||
vimscript/mal.vim
|
||||
clisp/*.fas
|
||||
clisp/*.lib
|
||||
basic/step0_repl.bas
|
||||
basic/step1_read_print.bas
|
||||
basic/step2_eval.bas
|
||||
basic/step3_env.bas
|
||||
basic/step4_if_fn_do.bas
|
||||
basic/step5_tco.bas
|
||||
basic/step6_file.bas
|
||||
basic/step7_quote.bas
|
||||
basic/step8_macros.bas
|
||||
basic/step9_try.bas
|
||||
basic/stepA_mal.bas
|
||||
basic/*.prg
|
||||
|
@ -8,6 +8,7 @@ matrix:
|
||||
- {env: IMPL=ada, services: [docker]}
|
||||
- {env: IMPL=awk, services: [docker]}
|
||||
- {env: IMPL=bash, services: [docker]}
|
||||
- {env: IMPL=basic, services: [docker]}
|
||||
- {env: IMPL=c, services: [docker]}
|
||||
- {env: IMPL=cpp, services: [docker]}
|
||||
- {env: IMPL=coffee, services: [docker]}
|
||||
|
4
Makefile
4
Makefile
@ -77,7 +77,7 @@ DOCKERIZE =
|
||||
# Settings
|
||||
#
|
||||
|
||||
IMPLS = ada awk bash c d chuck clojure coffee clisp cpp crystal cs erlang elisp \
|
||||
IMPLS = ada awk bash basic c d chuck clojure coffee clisp cpp crystal cs erlang elisp \
|
||||
elixir es6 factor forth fsharp go groovy guile haskell haxe \
|
||||
io java julia js kotlin logo lua make mal ocaml matlab miniMAL \
|
||||
nim objc objpascal perl perl6 php plpgsql plsql powershell ps \
|
||||
@ -109,6 +109,7 @@ regress_step9 = $(regress_step8) step9
|
||||
regress_stepA = $(regress_step9) stepA
|
||||
|
||||
test_EXCLUDES += test^bash^step5 # never completes at 10,000
|
||||
test_EXCLUDES += test^basic^step5 # too slow, and limited to ints of 2^16
|
||||
test_EXCLUDES += test^logo^step5 # too slow for 10,000
|
||||
test_EXCLUDES += test^make^step5 # no TCO capability (iteration or recursion)
|
||||
test_EXCLUDES += test^mal^step5 # host impl dependent
|
||||
@ -146,6 +147,7 @@ STEP_TEST_FILES = $(strip $(wildcard \
|
||||
ada_STEP_TO_PROG = ada/$($(1))
|
||||
awk_STEP_TO_PROG = awk/$($(1)).awk
|
||||
bash_STEP_TO_PROG = bash/$($(1)).sh
|
||||
basic_STEP_TO_PROG = basic/$($(1)).bas
|
||||
c_STEP_TO_PROG = c/$($(1))
|
||||
d_STEP_TO_PROG = d/$($(1))
|
||||
chuck_STEP_TO_PROG = chuck/$($(1)).ck
|
||||
|
32
README.md
32
README.md
@ -6,11 +6,12 @@
|
||||
|
||||
Mal is a Clojure inspired Lisp interpreter.
|
||||
|
||||
Mal is implemented in 59 languages:
|
||||
Mal is implemented in 60 languages:
|
||||
|
||||
* Ada
|
||||
* GNU awk
|
||||
* Bash shell
|
||||
* Basic (C64 and QBasic)
|
||||
* C
|
||||
* C++
|
||||
* C#
|
||||
@ -153,6 +154,35 @@ cd bash
|
||||
bash stepX_YYY.sh
|
||||
```
|
||||
|
||||
### Basic (C64 and QBasic)
|
||||
|
||||
The Basic implementation uses a preprocessor that can generate Basic
|
||||
code that is compatible with both C64 Basic (CBM v2) and QBasic. The
|
||||
C64 mode has been tested with
|
||||
[cbmbasic](https://github.com/kanaka/cbmbasic) (the patched version is
|
||||
currently required to fix issues with line input) and the QBasic mode
|
||||
has been tested with [qb64](http://www.qb64.net/).
|
||||
|
||||
Generate C64 code and run it using cbmbasic:
|
||||
|
||||
```
|
||||
cd basic
|
||||
make stepX_YYY.bas
|
||||
STEP=stepX_YYY ./run
|
||||
```
|
||||
|
||||
Generate QBasic code and load it into qb64:
|
||||
|
||||
```
|
||||
cd basic
|
||||
make MODE=qbasic stepX_YYY.bas
|
||||
./qb64 stepX_YYY.bas
|
||||
```
|
||||
|
||||
Thanks to [Steven Syrek](https://github.com/sjsyrek) for the original
|
||||
inspiration for this implementation.
|
||||
|
||||
|
||||
### C
|
||||
|
||||
The C implementation of mal requires the following libraries (lib and
|
||||
|
1
basic/.args.mal
Normal file
1
basic/.args.mal
Normal file
@ -0,0 +1 @@
|
||||
(list )
|
34
basic/Dockerfile
Normal file
34
basic/Dockerfile
Normal file
@ -0,0 +1,34 @@
|
||||
FROM ubuntu:wily
|
||||
MAINTAINER Joel Martin <github@martintribe.org>
|
||||
|
||||
##########################################################
|
||||
# General requirements for testing or common across many
|
||||
# implementations
|
||||
##########################################################
|
||||
|
||||
RUN apt-get -y update
|
||||
|
||||
# Required for running tests
|
||||
RUN apt-get -y install make python
|
||||
|
||||
# Some typical implementation and test requirements
|
||||
RUN apt-get -y install curl libreadline-dev libedit-dev
|
||||
|
||||
RUN mkdir -p /mal
|
||||
WORKDIR /mal
|
||||
|
||||
##########################################################
|
||||
# Specific implementation requirements
|
||||
##########################################################
|
||||
|
||||
# cbmbasic
|
||||
RUN apt-get install -y gcc unzip patch
|
||||
RUN cd /tmp && \
|
||||
curl -L https://github.com/kanaka/cbmbasic/archive/master.zip -o cbmbasic.zip && \
|
||||
unzip cbmbasic.zip && \
|
||||
cd cbmbasic-master && \
|
||||
make && \
|
||||
cp cbmbasic /usr/bin/cbmbasic && \
|
||||
cd .. && \
|
||||
rm -r cbmbasic*
|
||||
|
66
basic/Makefile
Normal file
66
basic/Makefile
Normal file
@ -0,0 +1,66 @@
|
||||
MODE = cbm
|
||||
BASICPP_OPTS = --mode $(MODE)
|
||||
|
||||
STEPS4_A = step4_if_fn_do.bas step5_tco.bas step6_file.bas \
|
||||
step7_quote.bas step8_macros.bas step9_try.bas stepA_mal.bas
|
||||
STEPS3_A = step3_env.bas $(STEPS4_A)
|
||||
STEPS1_A = step1_read_print.bas step2_eval.bas $(STEPS3_A)
|
||||
STEPS0_A = step0_repl.bas $(STEPS1_A)
|
||||
|
||||
all: $(STEPS0_A)
|
||||
|
||||
step%.bas: step%.in.bas
|
||||
./basicpp.py $(BASICPP_OPTS) $< > $@
|
||||
|
||||
$(STEPS0_A): readline.in.bas
|
||||
$(STEPS1_A): debug.in.bas types.in.bas reader.in.bas printer.in.bas
|
||||
$(STEPS3_A): env.in.bas
|
||||
$(STEPS4_A): core.in.bas
|
||||
|
||||
tests/%.bas: tests/%.in.bas
|
||||
./basicpp.py $(BASICPP_OPTS) $< > $@
|
||||
|
||||
|
||||
# CBM/C64 image rules
|
||||
|
||||
step%.prg: step%.bas
|
||||
cat $< | tr "A-Z" "a-z" > $<.tmp
|
||||
#cat $< | sed 's/["]\@<!\<\w\+\>["]\@!/\L&/g' > $<.tmp
|
||||
petcat -w2 -nc -o $@ $<.tmp
|
||||
#rm $<.tmp
|
||||
|
||||
mal.prg: stepA_mal.prg
|
||||
cp $< $@
|
||||
|
||||
.args.mal.prg: .args.mal
|
||||
petcat -text -w2 -o $@ $<
|
||||
|
||||
core.mal.prg: ../core.mal
|
||||
petcat -text -w2 -o $@ $<
|
||||
|
||||
mal.d64: mal.prg .args.mal.prg core.mal.prg
|
||||
c1541 -format "mal,01" d64 $@ \
|
||||
-attach $@ \
|
||||
-write $< mal \
|
||||
-write .args.mal.prg .args.mal \
|
||||
-write core.mal.prg core.mal
|
||||
|
||||
|
||||
# Clean and Stats rules
|
||||
|
||||
.PHONY: clean stats
|
||||
|
||||
clean:
|
||||
rm -f $(STEPS0_A) *.d64 *.prg
|
||||
|
||||
|
||||
SOURCES_LISP = env.in.bas core.in.bas stepA_mal.in.bas
|
||||
SOURCES = readline.in.bas types.in.bas reader.in.bas printer.in.bas $(SOURCES_LISP)
|
||||
|
||||
stats: $(SOURCES)
|
||||
@wc $^
|
||||
@printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*REM |^[[:space:]]*$$" $^ | wc` "[comments/blanks]"
|
||||
stats-lisp: $(SOURCES_LISP)
|
||||
@wc $^
|
||||
@printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*#|^[[:space:]]*REM |^[[:space:]]*$$" $^ | wc` "[comments/blanks]"
|
||||
|
301
basic/basicpp.py
Executable file
301
basic/basicpp.py
Executable file
@ -0,0 +1,301 @@
|
||||
#!/usr/bin/env python
|
||||
|
||||
from __future__ import print_function
|
||||
import argparse
|
||||
import re
|
||||
import sys
|
||||
|
||||
def debug(*args, **kwargs):
|
||||
print(*args, file=sys.stderr, **kwargs)
|
||||
|
||||
def parse_args():
|
||||
parser = argparse.ArgumentParser(description='Preprocess Basic code.')
|
||||
parser.add_argument('infiles', type=str, nargs='+',
|
||||
help='the Basic files to preprocess')
|
||||
parser.add_argument('--mode', choices=["cbm", "qbasic"], default="cbm")
|
||||
parser.add_argument('--keep-rems', action='store_true', default=False,
|
||||
help='The type of REMs to keep (0 (none) -> 4 (all)')
|
||||
parser.add_argument('--keep-blank-lines', action='store_true', default=False,
|
||||
help='Keep blank lines from the original file')
|
||||
parser.add_argument('--keep-indent', action='store_true', default=False,
|
||||
help='Keep line identing')
|
||||
parser.add_argument('--skip-misc-fixups', action='store_true', default=False,
|
||||
help='Skip miscellaneous fixup/shrink fixups')
|
||||
parser.add_argument('--skip-combine-lines', action='store_true', default=False,
|
||||
help='Do not combine lines using the ":" separator')
|
||||
|
||||
args = parser.parse_args()
|
||||
if args.keep_rems and not args.skip_combine_lines:
|
||||
debug("Option --keep-rems implies --skip-combine-lines ")
|
||||
args.skip_combine_lines = True
|
||||
|
||||
if args.mode == 'qbasic' and not args.skip_misc_fixups:
|
||||
debug("Mode 'qbasic' implies --skip-misc-fixups")
|
||||
args.skip_misc_fixups = True
|
||||
|
||||
return args
|
||||
|
||||
# pull in include files
|
||||
def resolve_includes(orig_lines, keep_rems=0):
|
||||
included = {}
|
||||
lines = []
|
||||
for line in orig_lines:
|
||||
m = re.match(r"^ *REM \$INCLUDE: '([^']*)' *$", line)
|
||||
if m and m.group(1) not in included:
|
||||
f = m.group(1)
|
||||
if f not in included:
|
||||
ilines = [l.rstrip() for l in open(f).readlines()]
|
||||
if keep_rems: lines.append("REM vvv BEGIN '%s' vvv" % f)
|
||||
lines.extend(ilines)
|
||||
if keep_rems: lines.append("REM ^^^ END '%s' ^^^" % f)
|
||||
else:
|
||||
debug("Ignoring already included file: %s" % f)
|
||||
else:
|
||||
lines.append(line)
|
||||
return lines
|
||||
|
||||
def resolve_mode(orig_lines, mode):
|
||||
lines = []
|
||||
for line in orig_lines:
|
||||
m = re.match(r"^ *#([^ ]*) (.*)$", line)
|
||||
if m:
|
||||
if m.group(1) == mode:
|
||||
lines.append(m.group(2))
|
||||
continue
|
||||
lines.append(line)
|
||||
return lines
|
||||
|
||||
def drop_blank_lines(orig_lines):
|
||||
lines = []
|
||||
for line in orig_lines:
|
||||
if re.match(r"^\W*$", line): continue
|
||||
lines.append(line)
|
||||
return lines
|
||||
|
||||
|
||||
def drop_rems(orig_lines):
|
||||
lines = []
|
||||
for line in orig_lines:
|
||||
if re.match(r"^ *REM", line):
|
||||
continue
|
||||
m = re.match(r"^(.*): *REM .*$", line)
|
||||
if m:
|
||||
lines.append(m.group(1))
|
||||
else:
|
||||
lines.append(line)
|
||||
return lines
|
||||
|
||||
def remove_indent(orig_lines):
|
||||
lines = []
|
||||
for line in orig_lines:
|
||||
m = re.match(r"^ *([^ ].*)$", line)
|
||||
lines.append(m.group(1))
|
||||
return lines
|
||||
|
||||
def misc_fixups(orig_lines):
|
||||
text = "\n".join(orig_lines)
|
||||
text = re.sub(r"\bTHEN GOTO\b", "THEN", text)
|
||||
text = re.sub(r"\bPRINT \"", "PRINT\"", text)
|
||||
text = re.sub(r"\bIF ", "IF", text)
|
||||
text = re.sub(r"AND ([0-9])", r"AND\g<1>", text)
|
||||
return text.split("\n")
|
||||
|
||||
def finalize(lines, args):
|
||||
labels_lines = {}
|
||||
lines_labels = {}
|
||||
call_index = {}
|
||||
|
||||
cur_sub = None
|
||||
|
||||
# number lines, remove labels (but track line number), and replace
|
||||
# CALLs with a stack based GOTO
|
||||
src_lines = lines
|
||||
lines = []
|
||||
lnum=1
|
||||
for line in src_lines:
|
||||
|
||||
# Drop labels (track line number for GOTO/GOSUB)
|
||||
m = re.match(r"^ *([^ ]*): *$", line)
|
||||
if m:
|
||||
label = m.groups(1)[0]
|
||||
labels_lines[label] = lnum
|
||||
lines_labels[lnum] = label
|
||||
continue
|
||||
|
||||
if re.match(r".*\bCALL *([^ :]*) *:", line):
|
||||
raise Exception("CALL is not the last thing on line %s" % lnum)
|
||||
|
||||
# Replace CALLs (track line number for replacement later)
|
||||
#m = re.match(r"\bCALL *([^ :]*) *$", line)
|
||||
m = re.match(r"(.*)\bCALL *([^ :]*) *$", line)
|
||||
if m:
|
||||
prefix = m.groups(1)[0]
|
||||
sub = m.groups(1)[1]
|
||||
if not call_index.has_key(sub):
|
||||
call_index[sub] = 0
|
||||
call_index[sub] += 1
|
||||
label = sub+"_"+str(call_index[sub])
|
||||
|
||||
# Replace the CALL with stack based GOTO
|
||||
lines.append("%s %sX=X+1:X%%(X)=%s:GOTO %s" % (
|
||||
lnum, prefix, call_index[sub], sub))
|
||||
lnum += 1
|
||||
|
||||
# Add the return spot
|
||||
labels_lines[label] = lnum
|
||||
lines_labels[lnum] = label
|
||||
lines.append("%s X=X-1" % lnum)
|
||||
lnum += 1
|
||||
continue
|
||||
|
||||
lines.append("%s %s" % (lnum, line))
|
||||
lnum += 1
|
||||
|
||||
# remove SUB (but track lines), and replace END SUB with ON GOTO
|
||||
# that returns to original caller
|
||||
src_lines = lines
|
||||
lines = []
|
||||
lnum=1
|
||||
for line in src_lines:
|
||||
# Drop subroutine defs (track line number for CALLS)
|
||||
m = re.match(r"^([0-9][0-9]*) *SUB *([^ ]*) *$", line)
|
||||
if m:
|
||||
lnum = int(m.groups(1)[0])+1
|
||||
label = m.groups(1)[1]
|
||||
cur_sub = label
|
||||
labels_lines[label] = lnum
|
||||
lines_labels[lnum] = label
|
||||
continue
|
||||
|
||||
# Drop END SUB (track line number for replacement later)
|
||||
m = re.match(r"^([0-9][0-9]*) *END SUB *$", line)
|
||||
if m:
|
||||
if cur_sub == None:
|
||||
raise Exception("END SUB found without preceeding SUB")
|
||||
lnum = int(m.groups(1)[0])
|
||||
index = call_index[cur_sub]
|
||||
|
||||
ret_labels = [cur_sub+"_"+str(i) for i in range(1, index+1)]
|
||||
line = "%s ON X%%(X) GOTO %s" % (lnum, ",".join(ret_labels))
|
||||
cur_sub = None
|
||||
|
||||
lines.append(line)
|
||||
|
||||
def update_labels_lines(text, a, b):
|
||||
stext = ""
|
||||
while stext != text:
|
||||
stext = text
|
||||
text = re.sub(r"(THEN) %s\b" % a, r"THEN %s" % b, stext)
|
||||
#text = re.sub(r"(THEN)%s\b" % a, r"THEN%s" % b, stext)
|
||||
text = re.sub(r"(ON [^:\n]* GOTO [^:\n]*)\b%s\b" % a, r"\g<1>%s" % b, text)
|
||||
text = re.sub(r"(ON [^:\n]* GOSUB [^:\n]*)\b%s\b" % a, r"\g<1>%s" % b, text)
|
||||
text = re.sub(r"(GOSUB) %s\b" % a, r"\1 %s" % b, text)
|
||||
text = re.sub(r"(GOTO) %s\b" % a, r"\1 %s" % b, text)
|
||||
#text = re.sub(r"(GOTO)%s\b" % a, r"\1%s" % b, text)
|
||||
return text
|
||||
|
||||
# search for and replace GOTO/GOSUBs
|
||||
src_lines = lines
|
||||
text = "\n".join(lines)
|
||||
for label, lnum in labels_lines.items():
|
||||
text = update_labels_lines(text, label, lnum)
|
||||
lines = text.split("\n")
|
||||
|
||||
# combine lines
|
||||
if not args.skip_combine_lines:
|
||||
renumber = {}
|
||||
src_lines = lines
|
||||
lines = []
|
||||
pos = 0
|
||||
acc_line = ""
|
||||
def renum(line):
|
||||
lnum = len(lines)+1
|
||||
renumber[old_num] = lnum
|
||||
return "%s %s" % (lnum, line)
|
||||
while pos < len(src_lines):
|
||||
line = src_lines[pos]
|
||||
m = re.match(r"^([0-9]*) (.*)$", line)
|
||||
old_num = int(m.group(1))
|
||||
line = m.group(2)
|
||||
|
||||
if acc_line == "":
|
||||
# Starting a new line
|
||||
acc_line = renum(line)
|
||||
elif old_num in lines_labels or re.match(r"^ *FOR\b.*", line):
|
||||
# This is a GOTO/GOSUB target or FOR loop so it must
|
||||
# be on a line by itself
|
||||
lines.append(acc_line)
|
||||
acc_line = renum(line)
|
||||
elif re.match(r".*\b(?:GOTO|THEN|RETURN)\b.*", acc_line):
|
||||
# GOTO/THEN/RETURN are last thing on the line
|
||||
lines.append(acc_line)
|
||||
acc_line = renum(line)
|
||||
# TODO: not sure why this is 88 rather than 80
|
||||
elif len(acc_line) + 1 + len(line) < 88:
|
||||
# Continue building up the line
|
||||
acc_line = acc_line + ":" + line
|
||||
# GOTO/IF/RETURN must be the last things on a line so
|
||||
# start a new line
|
||||
if re.match(r".*\b(?:GOTO|THEN|RETURN)\b.*", line):
|
||||
lines.append(acc_line)
|
||||
acc_line = ""
|
||||
else:
|
||||
# Too long so start a new line
|
||||
lines.append(acc_line)
|
||||
acc_line = renum(line)
|
||||
pos += 1
|
||||
if acc_line != "":
|
||||
lines.append(acc_line)
|
||||
|
||||
# Finally renumber GOTO/GOSUBS
|
||||
src_lines = lines
|
||||
text = "\n".join(lines)
|
||||
# search for and replace GOTO/GOSUBs
|
||||
for a in sorted(renumber.keys()):
|
||||
b = renumber[a]
|
||||
text = update_labels_lines(text, a, b)
|
||||
lines = text.split("\n")
|
||||
|
||||
|
||||
return lines
|
||||
|
||||
if __name__ == '__main__':
|
||||
args = parse_args()
|
||||
|
||||
debug("Preprocessing basic files: "+", ".join(args.infiles))
|
||||
|
||||
# read in lines
|
||||
lines = [l.rstrip() for f in args.infiles
|
||||
for l in open(f).readlines()]
|
||||
debug("Original lines: %s" % len(lines))
|
||||
|
||||
# pull in include files
|
||||
lines = resolve_includes(lines, keep_rems=args.keep_rems)
|
||||
debug("Lines after includes: %s" % len(lines))
|
||||
|
||||
lines = resolve_mode(lines, mode=args.mode)
|
||||
debug("Lines after resolving mode specific lines: %s" % len(lines))
|
||||
|
||||
# drop blank lines
|
||||
if not args.keep_blank_lines:
|
||||
lines = drop_blank_lines(lines)
|
||||
debug("Lines after dropping blank lines: %s" % len(lines))
|
||||
|
||||
# keep/drop REMs
|
||||
if not args.keep_rems:
|
||||
lines = drop_rems(lines)
|
||||
debug("Lines after dropping REMs: %s" % len(lines))
|
||||
|
||||
# keep/remove the indenting
|
||||
if not args.keep_indent:
|
||||
lines = remove_indent(lines)
|
||||
|
||||
# apply some miscellaneous simple fixups/regex transforms
|
||||
if not args.skip_misc_fixups:
|
||||
lines = misc_fixups(lines)
|
||||
|
||||
# number lines, drop/keep labels, combine lines
|
||||
lines = finalize(lines, args)
|
||||
debug("Lines after finalizing: %s" % len(lines))
|
||||
|
||||
print("\n".join(lines))
|
26
basic/cbmbasic_console.patch
Normal file
26
basic/cbmbasic_console.patch
Normal file
@ -0,0 +1,26 @@
|
||||
diff --git a/runtime.c b/runtime.c
|
||||
index 3066580..c635bd4 100644
|
||||
--- a/runtime.c
|
||||
+++ b/runtime.c
|
||||
@@ -535,7 +535,8 @@ printf("CHROUT: %d @ %x,%x,%x,%x\n", A, a, b, c, d);
|
||||
left_cursor();
|
||||
break;
|
||||
case '"':
|
||||
- kernal_quote = 1;
|
||||
+ // jdm: this doesn't match C64 behavior
|
||||
+ //kernal_quote = 1;
|
||||
// fallthrough
|
||||
default:
|
||||
putchar(A);
|
||||
@@ -838,8 +839,10 @@ GETIN() {
|
||||
/*Notice that EOF is also turned off in non-canonical mode*/
|
||||
A = getchar();
|
||||
if (A == 255) { A = 4; } // map actual EOF to 4
|
||||
+
|
||||
+ // jdm: this doesn't match C64 behavior
|
||||
/* Simulate echo */
|
||||
- if (A != 0 && A != 4) { putchar(A); }
|
||||
+ //if (A != 0 && A != 4) { putchar(A); }
|
||||
|
||||
/*restore the old settings*/
|
||||
tcsetattr( STDIN_FILENO, TCSANOW, &oldt);
|
616
basic/core.in.bas
Normal file
616
basic/core.in.bas
Normal file
@ -0,0 +1,616 @@
|
||||
REM APPLY should really be in types.in.bas but it is here because it
|
||||
REM calls DO_TCO_FUNCTION so it will cause syntax errors for steps1-3
|
||||
REM if it is in types.in.bas because there are unresolved labels.
|
||||
|
||||
REM APPLY(F, AR) -> R
|
||||
REM - restores E
|
||||
REM - call using GOTO and with return label/address on the stack
|
||||
SUB APPLY
|
||||
REM if metadata, get the actual object
|
||||
IF (Z%(F,0)AND 31)>=16 THEN F=Z%(F,1)
|
||||
|
||||
IF (Z%(F,0)AND 31)=9 THEN GOTO APPLY_FUNCTION
|
||||
IF (Z%(F,0)AND 31)=10 THEN GOTO APPLY_MAL_FUNCTION
|
||||
IF (Z%(F,0)AND 31)=11 THEN GOTO APPLY_MAL_FUNCTION
|
||||
|
||||
APPLY_FUNCTION:
|
||||
REM regular function
|
||||
IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO APPLY_DONE
|
||||
REM for recur functions (apply, map, swap!), use GOTO
|
||||
IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
|
||||
GOTO APPLY_DONE
|
||||
|
||||
APPLY_MAL_FUNCTION:
|
||||
X=X+1:X%(X)=E: REM save the current environment
|
||||
|
||||
REM create new environ using env and params stored in the
|
||||
REM function and bind the params to the apply arguments
|
||||
O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
|
||||
|
||||
A=Z%(F,1):E=R:CALL EVAL
|
||||
|
||||
AY=E:GOSUB RELEASE: REM release the new environment
|
||||
|
||||
E=X%(X):X=X-1: REM pop/restore the saved environment
|
||||
|
||||
APPLY_DONE:
|
||||
END SUB
|
||||
|
||||
|
||||
REM DO_TCO_FUNCTION(F, AR)
|
||||
SUB DO_TCO_FUNCTION
|
||||
FF=Z%(F,1)
|
||||
|
||||
REM Get argument values
|
||||
R=AR+1:GOSUB DEREF_R:AA=R
|
||||
R=Z%(AR,1)+1:GOSUB DEREF_R:AB=R
|
||||
|
||||
ON FF-60 GOTO DO_APPLY,DO_MAP,DO_SWAP_BANG
|
||||
|
||||
DO_APPLY:
|
||||
F=AA
|
||||
AR=Z%(AR,1)
|
||||
B=AR:GOSUB COUNT:R4=R
|
||||
|
||||
A=Z%(AR+1,1)
|
||||
REM no intermediate args, but not a list, so convert it first
|
||||
IF R4<=1 AND (Z%(A,0)AND 31)<>6 THEN T=6:GOSUB FORCE_SEQ_TYPE:GOTO DO_APPLY_2
|
||||
REM no intermediate args, just call APPLY directly
|
||||
IF R4<=1 THEN GOTO DO_APPLY_1
|
||||
|
||||
REM prepend intermediate args to final args element
|
||||
A=AR:B=0:C=R4-1:GOSUB SLICE
|
||||
REM release the terminator of new list (we skip over it)
|
||||
AY=Z%(R6,1):GOSUB RELEASE
|
||||
REM attach end of slice to final args element
|
||||
Z%(R6,1)=Z%(A+1,1)
|
||||
Z%(Z%(A+1,1),0)=Z%(Z%(A+1,1),0)+32
|
||||
|
||||
GOTO DO_APPLY_2
|
||||
|
||||
DO_APPLY_1:
|
||||
AR=A:CALL APPLY
|
||||
|
||||
GOTO DO_TCO_FUNCTION_DONE
|
||||
|
||||
DO_APPLY_2:
|
||||
X=X+1:X%(X)=R: REM push/save new args for release
|
||||
|
||||
AR=R:CALL APPLY
|
||||
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE: REM pop/release new args
|
||||
GOTO DO_TCO_FUNCTION_DONE
|
||||
|
||||
DO_MAP:
|
||||
F=AA
|
||||
|
||||
REM first result list element
|
||||
T=6:L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM push future return val, prior entry, F and AB
|
||||
X=X+4:X%(X-3)=R:X%(X-2)=0:X%(X-1)=F:X%(X)=AB
|
||||
|
||||
DO_MAP_LOOP:
|
||||
REM set previous to current if not the first element
|
||||
IF X%(X-2)<>0 THEN Z%(X%(X-2),1)=R
|
||||
REM update previous reference to current
|
||||
X%(X-2)=R
|
||||
|
||||
IF Z%(AB,1)=0 THEN GOTO DO_MAP_DONE
|
||||
|
||||
REM create argument list for apply call
|
||||
Z%(3,0)=Z%(3,0)+32
|
||||
REM inc ref cnt of referred argument
|
||||
T=6:L=3:N=Z%(AB+1,1):GOSUB ALLOC
|
||||
|
||||
REM push argument list
|
||||
X=X+1:X%(X)=R
|
||||
|
||||
AR=R:CALL APPLY
|
||||
|
||||
REM pop apply args and release them
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
|
||||
REM set the result value
|
||||
Z%(X%(X-2)+1,1)=R
|
||||
|
||||
IF ER<>-2 THEN GOTO DO_MAP_DONE
|
||||
|
||||
REM restore F
|
||||
F=X%(X-1)
|
||||
|
||||
REM update AB to next source element
|
||||
X%(X)=Z%(X%(X),1)
|
||||
AB=X%(X)
|
||||
|
||||
REM allocate next element
|
||||
T=6:L=0:N=0:GOSUB ALLOC
|
||||
|
||||
GOTO DO_MAP_LOOP
|
||||
|
||||
DO_MAP_DONE:
|
||||
REM if no error, get return val
|
||||
IF ER=-2 THEN R=X%(X-3)
|
||||
REM otherwise, free the return value and return nil
|
||||
IF ER<>-2 THEN R=0:AY=X%(X-3):GOSUB RELEASE
|
||||
|
||||
REM pop everything off stack
|
||||
X=X-4
|
||||
GOTO DO_TCO_FUNCTION_DONE
|
||||
|
||||
|
||||
DO_SWAP_BANG:
|
||||
F=AB
|
||||
|
||||
REM add atom to front of the args list
|
||||
T=6:L=Z%(Z%(AR,1),1):N=Z%(AA,1):GOSUB ALLOC: REM cons
|
||||
AR=R
|
||||
|
||||
REM push args for release after
|
||||
X=X+1:X%(X)=AR
|
||||
|
||||
REM push atom
|
||||
X=X+1:X%(X)=AA
|
||||
|
||||
CALL APPLY
|
||||
|
||||
REM pop atom
|
||||
AA=X%(X):X=X-1
|
||||
|
||||
REM pop and release args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
|
||||
REM use reset to update the value
|
||||
AB=R:GOSUB DO_RESET_BANG
|
||||
|
||||
REM but decrease ref cnt of return by 1 (not sure why)
|
||||
AY=R:GOSUB RELEASE
|
||||
|
||||
GOTO DO_TCO_FUNCTION_DONE
|
||||
|
||||
DO_TCO_FUNCTION_DONE:
|
||||
END SUB
|
||||
|
||||
|
||||
REM DO_FUNCTION(F, AR)
|
||||
DO_FUNCTION:
|
||||
REM Get the function number
|
||||
FF=Z%(F,1)
|
||||
|
||||
REM Get argument values
|
||||
R=AR+1:GOSUB DEREF_R:AA=R
|
||||
R=Z%(AR,1)+1:GOSUB DEREF_R:AB=R
|
||||
|
||||
REM Switch on the function number
|
||||
IF FF>59 THEN ER=-1:ER$="unknown function"+STR$(FF):RETURN
|
||||
ON INT(FF/10)+1 GOTO DO_1_9,DO_10_19,DO_20_29,DO_30_39,DO_40_49,DO_50_59
|
||||
|
||||
DO_1_9:
|
||||
ON FF GOTO DO_EQUAL_Q,DO_THROW,DO_NIL_Q,DO_TRUE_Q,DO_FALSE_Q,DO_STRING_Q,DO_SYMBOL,DO_SYMBOL_Q,DO_KEYWORD
|
||||
DO_10_19:
|
||||
ON FF-9 GOTO DO_KEYWORD_Q,DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE,DO_SLURP,DO_LT,DO_LTE
|
||||
DO_20_29:
|
||||
ON FF-19 GOTO DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS,DO_LIST,DO_LIST_Q,DO_VECTOR
|
||||
DO_30_39:
|
||||
ON FF-29 GOTO DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q,DO_ASSOC,DO_THROW,DO_GET,DO_CONTAINS,DO_KEYS,DO_VALS,DO_SEQUENTIAL_Q
|
||||
DO_40_49:
|
||||
ON FF-39 GOTO DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT,DO_CONJ,DO_SEQ,DO_WITH_META
|
||||
DO_50_59:
|
||||
ON FF-49 GOTO DO_META,DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_EVAL,DO_READ_FILE
|
||||
REM ,DO_PR_MEMORY_SUMMARY
|
||||
|
||||
DO_EQUAL_Q:
|
||||
A=AA:B=AB:GOSUB EQUAL_Q
|
||||
R=R+1
|
||||
RETURN
|
||||
DO_THROW:
|
||||
ER=AA
|
||||
Z%(ER,0)=Z%(ER,0)+32
|
||||
R=0
|
||||
RETURN
|
||||
DO_NIL_Q:
|
||||
R=1
|
||||
IF AA=0 THEN R=2
|
||||
RETURN
|
||||
DO_TRUE_Q:
|
||||
R=1
|
||||
IF AA=2 THEN R=2
|
||||
RETURN
|
||||
DO_FALSE_Q:
|
||||
R=1
|
||||
IF AA=1 THEN R=2
|
||||
RETURN
|
||||
DO_STRING_Q:
|
||||
R=1
|
||||
IF (Z%(AA,0)AND 31)<>4 THEN RETURN
|
||||
IF MID$(S$(Z%(AA,1)),1,1)=CHR$(127) THEN RETURN
|
||||
R=2
|
||||
RETURN
|
||||
DO_SYMBOL:
|
||||
T=5:L=Z%(AA,1):GOSUB ALLOC
|
||||
RETURN
|
||||
DO_SYMBOL_Q:
|
||||
R=1
|
||||
IF (Z%(AA,0)AND 31)=5 THEN R=2
|
||||
RETURN
|
||||
DO_KEYWORD:
|
||||
A=Z%(AA,1)
|
||||
AS$=S$(A)
|
||||
IF MID$(AS$,1,1)<>CHR$(127) THEN AS$=CHR$(127)+AS$
|
||||
GOSUB STRING_
|
||||
T=4:L=R:GOSUB ALLOC
|
||||
RETURN
|
||||
DO_KEYWORD_Q:
|
||||
R=1
|
||||
IF (Z%(AA,0)AND 31)<>4 THEN RETURN
|
||||
IF MID$(S$(Z%(AA,1)),1,1)<>CHR$(127) THEN RETURN
|
||||
R=2
|
||||
RETURN
|
||||
|
||||
DO_PR_STR:
|
||||
AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
|
||||
AS$=R$:T=4:GOSUB STRING
|
||||
RETURN
|
||||
DO_STR:
|
||||
AZ=AR:PR=0:SE$="":GOSUB PR_STR_SEQ
|
||||
AS$=R$:T=4:GOSUB STRING
|
||||
RETURN
|
||||
DO_PRN:
|
||||
AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
|
||||
PRINT R$
|
||||
R=0
|
||||
RETURN
|
||||
DO_PRINTLN:
|
||||
AZ=AR:PR=0:SE$=" ":GOSUB PR_STR_SEQ
|
||||
PRINT R$
|
||||
R=0
|
||||
RETURN
|
||||
DO_READ_STRING:
|
||||
A$=S$(Z%(AA,1))
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
DO_READLINE:
|
||||
A$=S$(Z%(AA,1)):GOSUB READLINE
|
||||
IF EZ=1 THEN EZ=0:R=0:RETURN
|
||||
AS$=R$:T=4:GOSUB STRING
|
||||
RETURN
|
||||
DO_SLURP:
|
||||
R$=""
|
||||
#cbm OPEN 1,8,0,S$(Z%(AA,1))
|
||||
#qbasic A$=S$(Z%(AA,1))
|
||||
#qbasic IF NOT _FILEEXISTS(A$) THEN ER=-1:ER$="File not found":RETURN
|
||||
#qbasic OPEN A$ FOR INPUT AS #1
|
||||
DO_SLURP_LOOP:
|
||||
A$=""
|
||||
#cbm GET#1,A$
|
||||
#qbasic A$=INPUT$(1,1)
|
||||
#qbasic IF EOF(1) THEN RS=1:A$=A$+CHR$(10)+")":GOTO DO_SLURP_DONE
|
||||
IF ASC(A$)=10 THEN R$=R$+CHR$(13)
|
||||
IF (ASC(A$)<>10) AND (A$<>"") THEN R$=R$+A$
|
||||
#cbm IF (ST AND 64) THEN GOTO DO_SLURP_DONE
|
||||
#cbm IF (ST AND 255) THEN ER=-1:ER$="File read error "+STR$(ST):RETURN
|
||||
GOTO DO_SLURP_LOOP
|
||||
DO_SLURP_DONE:
|
||||
CLOSE 1
|
||||
AS$=R$:T=4:GOSUB STRING
|
||||
RETURN
|
||||
|
||||
DO_LT:
|
||||
R=1
|
||||
IF Z%(AA,1)<Z%(AB,1) THEN R=2
|
||||
RETURN
|
||||
DO_LTE:
|
||||
R=1
|
||||
IF Z%(AA,1)<=Z%(AB,1) THEN R=2
|
||||
RETURN
|
||||
DO_GT:
|
||||
R=1
|
||||
IF Z%(AA,1)>Z%(AB,1) THEN R=2
|
||||
RETURN
|
||||
DO_GTE:
|
||||
R=1
|
||||
IF Z%(AA,1)>=Z%(AB,1) THEN R=2
|
||||
RETURN
|
||||
|
||||
DO_ADD:
|
||||
T=2:L=Z%(AA,1)+Z%(AB,1):GOSUB ALLOC
|
||||
RETURN
|
||||
DO_SUB:
|
||||
T=2:L=Z%(AA,1)-Z%(AB,1):GOSUB ALLOC
|
||||
RETURN
|
||||
DO_MULT:
|
||||
T=2:L=Z%(AA,1)*Z%(AB,1):GOSUB ALLOC
|
||||
RETURN
|
||||
DO_DIV:
|
||||
T=2:L=Z%(AA,1)/Z%(AB,1):GOSUB ALLOC
|
||||
RETURN
|
||||
DO_TIME_MS:
|
||||
T=2:L=INT((TI-BT)*16.667):GOSUB ALLOC
|
||||
RETURN
|
||||
|
||||
DO_LIST:
|
||||
R=AR
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
RETURN
|
||||
DO_LIST_Q:
|
||||
A=AA:GOSUB LIST_Q
|
||||
R=R+1: REM map to mal false/true
|
||||
RETURN
|
||||
DO_VECTOR:
|
||||
A=AR:T=7:GOSUB FORCE_SEQ_TYPE
|
||||
RETURN
|
||||
DO_VECTOR_Q:
|
||||
R=1
|
||||
IF (Z%(AA,0)AND 31)=7 THEN R=2
|
||||
RETURN
|
||||
DO_HASH_MAP:
|
||||
A=AR:T=8:GOSUB FORCE_SEQ_TYPE
|
||||
RETURN
|
||||
DO_MAP_Q:
|
||||
R=1
|
||||
IF (Z%(AA,0)AND 31)=8 THEN R=2
|
||||
RETURN
|
||||
DO_ASSOC:
|
||||
H=AA
|
||||
AR=Z%(AR,1)
|
||||
DO_ASSOC_LOOP:
|
||||
R=AR+1:GOSUB DEREF_R:K=R
|
||||
R=Z%(AR,1)+1:GOSUB DEREF_R:V=R
|
||||
Z%(H,0)=Z%(H,0)+32
|
||||
GOSUB ASSOC1:H=R
|
||||
AR=Z%(Z%(AR,1),1)
|
||||
IF AR=0 OR Z%(AR,1)=0 THEN RETURN
|
||||
GOTO DO_ASSOC_LOOP
|
||||
DO_GET:
|
||||
IF AA=0 THEN R=0:RETURN
|
||||
H=AA:K=AB:GOSUB HASHMAP_GET
|
||||
GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
RETURN
|
||||
DO_CONTAINS:
|
||||
H=AA:K=AB:GOSUB HASHMAP_CONTAINS
|
||||
R=R+1
|
||||
RETURN
|
||||
DO_KEYS:
|
||||
GOTO DO_KEYS_VALS
|
||||
DO_VALS:
|
||||
AA=Z%(AA,1)
|
||||
DO_KEYS_VALS:
|
||||
REM first result list element
|
||||
T=6:L=0:N=0:GOSUB ALLOC:T2=R
|
||||
|
||||
DO_KEYS_VALS_LOOP:
|
||||
IF AA=0 OR Z%(AA,1)=0 THEN R=T2:RETURN
|
||||
|
||||
REM copy the value
|
||||
T1=Z%(AA+1,1)
|
||||
REM inc ref cnt of referred argument
|
||||
Z%(T1,0)=Z%(T1,0)+32
|
||||
Z%(R+1,1)=T1
|
||||
|
||||
T1=R: REM save previous
|
||||
REM allocate next element
|
||||
T=6:L=0:N=0:GOSUB ALLOC
|
||||
REM point previous element to this one
|
||||
Z%(T1,1)=R
|
||||
|
||||
IF Z%(Z%(AA,1),1)=0 THEN R=T2:RETURN
|
||||
|
||||
AA=Z%(Z%(AA,1),1)
|
||||
|
||||
GOTO DO_KEYS_VALS_LOOP
|
||||
|
||||
DO_SEQUENTIAL_Q:
|
||||
R=1
|
||||
IF (Z%(AA,0)AND 31)=6 OR (Z%(AA,0)AND 31)=7 THEN R=2
|
||||
RETURN
|
||||
DO_CONS:
|
||||
T=6:L=AB:N=AA:GOSUB ALLOC
|
||||
RETURN
|
||||
DO_CONCAT:
|
||||
REM if empty arguments, return empty list
|
||||
IF Z%(AR,1)=0 THEN R=3:Z%(R,0)=Z%(R,0)+32:RETURN
|
||||
|
||||
REM single argument
|
||||
IF Z%(Z%(AR,1),1)<>0 THEN GOTO DO_CONCAT_MULT
|
||||
REM force to list type
|
||||
A=AA:T=6:GOSUB FORCE_SEQ_TYPE
|
||||
RETURN
|
||||
|
||||
REM multiple arguments
|
||||
DO_CONCAT_MULT:
|
||||
CZ=X: REM save current stack position
|
||||
REM push arguments onto the stack
|
||||
DO_CONCAT_STACK:
|
||||
R=AR+1:GOSUB DEREF_R
|
||||
X=X+1:X%(X)=R: REM push sequence
|
||||
AR=Z%(AR,1)
|
||||
IF Z%(AR,1)<>0 THEN GOTO DO_CONCAT_STACK
|
||||
|
||||
REM pop last argument as our seq to prepend to
|
||||
AB=X%(X):X=X-1
|
||||
REM last arg/seq is not copied so we need to inc ref to it
|
||||
Z%(AB,0)=Z%(AB,0)+32
|
||||
DO_CONCAT_LOOP:
|
||||
IF X=CZ THEN R=AB:RETURN
|
||||
AA=X%(X):X=X-1: REM pop off next seq to prepend
|
||||
IF Z%(AA,1)=0 THEN GOTO DO_CONCAT_LOOP: REM skip empty seqs
|
||||
A=AA:B=0:C=-1:GOSUB SLICE
|
||||
|
||||
REM release the terminator of new list (we skip over it)
|
||||
AY=Z%(R6,1):GOSUB RELEASE
|
||||
REM attach new list element before terminator (last actual
|
||||
REM element to the next sequence
|
||||
Z%(R6,1)=AB
|
||||
|
||||
AB=R
|
||||
GOTO DO_CONCAT_LOOP
|
||||
DO_NTH:
|
||||
B=AA:GOSUB COUNT
|
||||
B=Z%(AB,1)
|
||||
IF R<=B THEN R=0:ER=-1:ER$="nth: index out of range":RETURN
|
||||
DO_NTH_LOOP:
|
||||
IF B=0 THEN GOTO DO_NTH_DONE
|
||||
B=B-1
|
||||
AA=Z%(AA,1)
|
||||
GOTO DO_NTH_LOOP
|
||||
DO_NTH_DONE:
|
||||
R=Z%(AA+1,1)
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
RETURN
|
||||
DO_FIRST:
|
||||
IF AA=0 THEN R=0:RETURN
|
||||
IF Z%(AA,1)=0 THEN R=0
|
||||
IF Z%(AA,1)<>0 THEN R=AA+1:GOSUB DEREF_R
|
||||
IF R<>0 THEN Z%(R,0)=Z%(R,0)+32
|
||||
RETURN
|
||||
DO_REST:
|
||||
IF AA=0 THEN R=3:Z%(R,0)=Z%(R,0)+32:RETURN
|
||||
IF Z%(AA,1)=0 THEN A=AA
|
||||
IF Z%(AA,1)<>0 THEN A=Z%(AA,1)
|
||||
T=6:GOSUB FORCE_SEQ_TYPE
|
||||
RETURN
|
||||
DO_EMPTY_Q:
|
||||
R=1
|
||||
IF Z%(AA,1)=0 THEN R=2
|
||||
RETURN
|
||||
DO_COUNT:
|
||||
B=AA:GOSUB COUNT
|
||||
T=2:L=R:GOSUB ALLOC
|
||||
RETURN
|
||||
DO_CONJ:
|
||||
R=0
|
||||
RETURN
|
||||
DO_SEQ:
|
||||
R=0
|
||||
RETURN
|
||||
|
||||
DO_WITH_META:
|
||||
T=Z%(AA,0)AND 31
|
||||
REM remove existing metadata first
|
||||
IF T>=16 THEN AA=Z%(AA,1):GOTO DO_WITH_META
|
||||
T=T+16:L=AA:N=AB:GOSUB ALLOC
|
||||
RETURN
|
||||
DO_META:
|
||||
IF (Z%(AA,0)AND 31)<16 THEN R=0:RETURN
|
||||
R=Z%(AA+1,1)
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
RETURN
|
||||
DO_ATOM:
|
||||
T=12:L=AA:GOSUB ALLOC
|
||||
RETURN
|
||||
DO_ATOM_Q:
|
||||
R=1
|
||||
IF (Z%(AA,0)AND 31)=12 THEN R=2
|
||||
RETURN
|
||||
DO_DEREF:
|
||||
R=Z%(AA,1):GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
RETURN
|
||||
DO_RESET_BANG:
|
||||
R=AB
|
||||
REM release current value
|
||||
AY=Z%(AA,1):GOSUB RELEASE
|
||||
REM inc ref by 2 for atom ownership and since we are returning it
|
||||
Z%(R,0)=Z%(R,0)+64
|
||||
REM update value
|
||||
Z%(AA,1)=R
|
||||
RETURN
|
||||
|
||||
REM DO_PR_MEMORY:
|
||||
REM P1=ZT:P2=-1:GOSUB PR_MEMORY
|
||||
REM RETURN
|
||||
REM DO_PR_MEMORY_SUMMARY:
|
||||
REM GOSUB PR_MEMORY_SUMMARY
|
||||
REM RETURN
|
||||
|
||||
DO_EVAL:
|
||||
A=AA:E=D:CALL EVAL
|
||||
RETURN
|
||||
|
||||
DO_READ_FILE:
|
||||
A$=S$(Z%(AA,1))
|
||||
GOSUB READ_FILE
|
||||
RETURN
|
||||
|
||||
INIT_CORE_SET_FUNCTION:
|
||||
GOSUB NATIVE_FUNCTION
|
||||
V=R:GOSUB ENV_SET_S
|
||||
RETURN
|
||||
|
||||
REM INIT_CORE_NS(E)
|
||||
INIT_CORE_NS:
|
||||
REM create the environment mapping
|
||||
REM must match DO_FUNCTION mappings
|
||||
|
||||
K$="=":A=1:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="throw":A=2:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="nil?":A=3:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="true?":A=4:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="false?":A=5:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="string?":A=6:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="symbol":A=7:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="symbol?":A=8:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="keyword":A=9:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="keyword?":A=10:GOSUB INIT_CORE_SET_FUNCTION
|
||||
|
||||
K$="pr-str":A=11:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="str":A=12:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="prn":A=13:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="println":A=14:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="read-string":A=15:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="readline":A=16:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="slurp":A=17:GOSUB INIT_CORE_SET_FUNCTION
|
||||
|
||||
K$="<":A=18:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="<=":A=19:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$=">":A=20:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$=">=":A=21:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="+":A=22:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="-":A=23:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="*":A=24:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="/":A=25:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="time-ms":A=26:GOSUB INIT_CORE_SET_FUNCTION
|
||||
|
||||
K$="list":A=27:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="list?":A=28:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="vector":A=29:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="vector?":A=30:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="hash-map":A=31:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="map?":A=32:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="assoc":A=33:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="dissoc":A=34:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="get":A=35:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="contains?":A=36:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="keys":A=37:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="vals":A=38:GOSUB INIT_CORE_SET_FUNCTION
|
||||
|
||||
K$="sequential?":A=39:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="cons":A=40:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="concat":A=41:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="nth":A=42:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="first":A=43:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="rest":A=44:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="empty?":A=45:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="count":A=46:GOSUB INIT_CORE_SET_FUNCTION
|
||||
|
||||
K$="conj":A=47:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="seq":A=48:GOSUB INIT_CORE_SET_FUNCTION
|
||||
|
||||
K$="with-meta":A=49:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="meta":A=50:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="atom":A=51:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="atom?":A=52:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="deref":A=53:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="reset!":A=54:GOSUB INIT_CORE_SET_FUNCTION
|
||||
|
||||
K$="eval":A=55:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="read-file":A=56:GOSUB INIT_CORE_SET_FUNCTION
|
||||
REM K$="pr-memory-summary":A=57:GOSUB INIT_CORE_SET_FUNCTION
|
||||
|
||||
REM these are in DO_TCO_FUNCTION
|
||||
K$="apply":A=61:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="map":A=62:GOSUB INIT_CORE_SET_FUNCTION
|
||||
K$="swap!":A=63:GOSUB INIT_CORE_SET_FUNCTION
|
||||
|
||||
RETURN
|
93
basic/debug.in.bas
Normal file
93
basic/debug.in.bas
Normal file
@ -0,0 +1,93 @@
|
||||
REM CHECK_FREE_LIST
|
||||
CHECK_FREE_LIST:
|
||||
REM start and accumulator
|
||||
P1=ZK
|
||||
P2=0
|
||||
CHECK_FREE_LIST_LOOP:
|
||||
IF P1>=ZI THEN GOTO CHECK_FREE_LIST_DONE
|
||||
IF (Z%(P1,0)AND 31)<>15 THEN P2=-1:GOTO CHECK_FREE_LIST_DONE
|
||||
P2=P2+(Z%(P1,0)AND-32)/32
|
||||
P1=Z%(P1,1)
|
||||
GOTO CHECK_FREE_LIST_LOOP
|
||||
CHECK_FREE_LIST_DONE:
|
||||
IF P2=-1 THEN PRINT "corrupt free list at "+STR$(P1)
|
||||
RETURN
|
||||
|
||||
PR_MEMORY_SUMMARY:
|
||||
PRINT
|
||||
#cbm PRINT "Free (FRE) :"+STR$(FRE(0))
|
||||
PRINT "Values (Z%) :"+STR$(ZI-1)+" /"+STR$(Z1)
|
||||
GOSUB CHECK_FREE_LIST: REM get count in P2
|
||||
PRINT " used:"+STR$(ZI-1-P2)+", freed:"+STR$(P2);
|
||||
PRINT ", after repl_env:"+STR$(ZT)
|
||||
PRINT "Strings (S$) :"+STR$(S)+" /"+STR$(Z2)
|
||||
PRINT "Stack (X%) :"+STR$(X+1)+" /"+STR$(Z3)
|
||||
RETURN
|
||||
|
||||
REM REM PR_MEMORY(P1, P2) -> nil
|
||||
REM PR_MEMORY:
|
||||
REM IF P2<P1 THEN P2=ZI-1
|
||||
REM PRINT "vvvvvv"
|
||||
REM PRINT "Z% Value Memory"+STR$(P1)+"->"+STR$(P2);
|
||||
REM PRINT " (ZI: "+STR$(ZI)+", ZK: "+STR$(ZK)+"):"
|
||||
REM IF P2<P1 THEN PRINT " ---":GOTO PR_MEMORY_AFTER_VALUES
|
||||
REM I=P1
|
||||
REM PR_MEMORY_VALUE_LOOP:
|
||||
REM IF I>P2 THEN GOTO PR_MEMORY_AFTER_VALUES
|
||||
REM PRINT " "+STR$(I);
|
||||
REM IF (Z%(I,0)AND 31)=15 THEN GOTO PR_MEMORY_FREE
|
||||
REM PRINT ": ref cnt: "+STR$((Z%(I,0)AND-32)/32);
|
||||
REM PRINT ", type: "+STR$(Z%(I,0)AND 31)+", value: "+STR$(Z%(I,1));
|
||||
REM IF (Z%(I,0)AND 31)=4 THEN PRINT " '"+S$(Z%(I,1))+"'";
|
||||
REM IF (Z%(I,0)AND 31)=5 THEN PRINT " "+S$(Z%(I,1))+"";
|
||||
REM PRINT
|
||||
REM I=I+1
|
||||
REM IF (Z%(I-1,0)AND 31)<>10 THEN GOTO PR_MEMORY_VALUE_LOOP
|
||||
REM PRINT " "+STR$(I)+": ";
|
||||
REM PRINT "params: "+STR$(Z%(I+1,0))+", env:"+STR$(Z%(I+1,1))
|
||||
REM I=I+1
|
||||
REM GOTO PR_MEMORY_VALUE_LOOP
|
||||
REM PR_MEMORY_FREE:
|
||||
REM PRINT ": FREE size: "+STR$((Z%(I,0)AND-32)/32)+", next: "+STR$(Z%(I,1));
|
||||
REM IF I=ZK THEN PRINT " (free list start)";
|
||||
REM PRINT
|
||||
REM IF (Z%(I,0)AND-32)=64 THEN I=I+1:PRINT " "+STR$(I)+": ---"
|
||||
REM I=I+1
|
||||
REM GOTO PR_MEMORY_VALUE_LOOP
|
||||
REM PR_MEMORY_AFTER_VALUES:
|
||||
REM PRINT "S$ String Memory (S: "+STR$(S)+"):"
|
||||
REM IF S<=0 THEN PRINT " ---":GOTO PR_MEMORY_SKIP_STRINGS
|
||||
REM FOR I=0 TO S-1
|
||||
REM PRINT " "+STR$(I)+": '"+S$(I)+"'"
|
||||
REM NEXT I
|
||||
REM PR_MEMORY_SKIP_STRINGS:
|
||||
REM PRINT "X% Stack Memory (X: "+STR$(X)+"):"
|
||||
REM IF X<0 THEN PRINT " ---":GOTO PR_MEMORY_SKIP_STACK
|
||||
REM FOR I=0 TO X
|
||||
REM PRINT " "+STR$(I)+": "+STR$(X%(I))
|
||||
REM NEXT I
|
||||
REM PR_MEMORY_SKIP_STACK:
|
||||
REM PRINT "^^^^^^"
|
||||
REM RETURN
|
||||
REM
|
||||
REM REM PR_OBJECT(P1) -> nil
|
||||
REM PR_OBJECT:
|
||||
REM RD=0
|
||||
REM
|
||||
REM RD=RD+1:X=X+1:X%(X)=P1
|
||||
REM
|
||||
REM PR_OBJ_LOOP:
|
||||
REM IF RD=0 THEN RETURN
|
||||
REM I=X%(X):RD=RD-1:X=X-1
|
||||
REM
|
||||
REM P2=Z%(I,0)AND 31
|
||||
REM PRINT " "+STR$(I);
|
||||
REM PRINT ": ref cnt: "+STR$((Z%(I,0)AND-32)/32);
|
||||
REM PRINT ", type: "+STR$(P2)+", value: "+STR$(Z%(I,1));
|
||||
REM IF P2=4 THEN PRINT " '"+S$(Z%(I,1))+"'";
|
||||
REM IF P2=5 THEN PRINT " "+S$(Z%(I,1))+"";
|
||||
REM PRINT
|
||||
REM IF P2<=5 OR P2=9 THEN GOTO PR_OBJ_LOOP
|
||||
REM IF Z%(I,1)<>0 THEN RD=RD+1:X=X+1:X%(X)=Z%(I,1)
|
||||
REM IF P2>=6 AND P2<=8 THEN RD=RD+1:X=X+1:X%(X)=I+1
|
||||
REM GOTO PR_OBJ_LOOP
|
92
basic/env.in.bas
Normal file
92
basic/env.in.bas
Normal file
@ -0,0 +1,92 @@
|
||||
|
||||
REM ENV_NEW(O) -> R
|
||||
ENV_NEW:
|
||||
REM allocate the data hashmap
|
||||
GOSUB HASHMAP
|
||||
ET=R
|
||||
|
||||
REM set the outer and data pointer
|
||||
T=13:L=R:N=O:GOSUB ALLOC
|
||||
AY=ET:GOSUB RELEASE: REM environment takes ownership
|
||||
RETURN
|
||||
|
||||
REM see RELEASE types.in.bas for environment cleanup
|
||||
|
||||
REM ENV_NEW_BINDS(O, BI, EX) -> R
|
||||
ENV_NEW_BINDS:
|
||||
GOSUB ENV_NEW
|
||||
E=R
|
||||
REM process bindings
|
||||
ENV_NEW_BINDS_LOOP:
|
||||
IF Z%(BI,1)=0 THEN R=E:RETURN
|
||||
REM get/deref the key from BI
|
||||
R=BI+1:GOSUB DEREF_R
|
||||
K=R
|
||||
|
||||
IF S$(Z%(K,1))="&" THEN GOTO EVAL_NEW_BINDS_VARGS
|
||||
|
||||
EVAL_NEW_BINDS_1x1:
|
||||
REM get/deref the key from EX
|
||||
R=EX+1:GOSUB DEREF_R
|
||||
V=R
|
||||
REM set the binding in the environment data
|
||||
GOSUB ENV_SET
|
||||
REM go to next element of BI and EX
|
||||
BI=Z%(BI,1)
|
||||
EX=Z%(EX,1)
|
||||
GOTO ENV_NEW_BINDS_LOOP
|
||||
|
||||
EVAL_NEW_BINDS_VARGS:
|
||||
REM get/deref the key from next element of BI
|
||||
BI=Z%(BI,1)
|
||||
R=BI+1:GOSUB DEREF_R
|
||||
K=R
|
||||
REM the value is the remaining list in EX
|
||||
A=EX:T=6:GOSUB FORCE_SEQ_TYPE
|
||||
V=R
|
||||
REM set the binding in the environment data
|
||||
GOSUB ENV_SET
|
||||
R=E
|
||||
AY=V:GOSUB RELEASE: REM list is owned by environment
|
||||
RETURN
|
||||
|
||||
REM ENV_SET(E, K, V) -> R
|
||||
ENV_SET:
|
||||
H=Z%(E,1)
|
||||
GOSUB ASSOC1
|
||||
Z%(E,1)=R
|
||||
R=V
|
||||
RETURN
|
||||
|
||||
REM ENV_SET_S(E, K$, V) -> R
|
||||
ENV_SET_S:
|
||||
H=Z%(E,1)
|
||||
GOSUB ASSOC1_S
|
||||
Z%(E,1)=R
|
||||
R=V
|
||||
RETURN
|
||||
|
||||
REM ENV_FIND(E, K) -> R
|
||||
REM Returns environment (R) containing K. If found, value found is
|
||||
REM in T4
|
||||
SUB ENV_FIND
|
||||
EF=E
|
||||
ENV_FIND_LOOP:
|
||||
H=Z%(EF,1)
|
||||
REM More efficient to use GET for value (R) and contains? (T3)
|
||||
GOSUB HASHMAP_GET
|
||||
REM if we found it, save value in T4 for ENV_GET
|
||||
IF T3=1 THEN T4=R:GOTO ENV_FIND_DONE
|
||||
EF=Z%(EF+1,1): REM get outer environment
|
||||
IF EF<>-1 THEN GOTO ENV_FIND_LOOP
|
||||
ENV_FIND_DONE:
|
||||
R=EF
|
||||
END SUB
|
||||
|
||||
REM ENV_GET(E, K) -> R
|
||||
ENV_GET:
|
||||
CALL ENV_FIND
|
||||
IF R=-1 THEN R=0:ER=-1:ER$="'"+S$(Z%(K,1))+"' not found":GOTO ENV_GET_RETURN
|
||||
R=T4:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO ENV_GET_RETURN
|
110
basic/printer.in.bas
Normal file
110
basic/printer.in.bas
Normal file
@ -0,0 +1,110 @@
|
||||
REM PR_STR(AZ, PR) -> R$
|
||||
PR_STR:
|
||||
RR$=""
|
||||
PR_STR_RECUR:
|
||||
T=Z%(AZ,0)AND 31
|
||||
REM PRINT "AZ: "+STR$(AZ)+", T: "+STR$(T)+", V: "+STR$(Z%(AZ,1))
|
||||
IF T=0 THEN R$="nil":RETURN
|
||||
REM if metadata, then get actual object
|
||||
IF T>=16 THEN AZ=Z%(AZ,1):GOTO PR_STR_RECUR
|
||||
ON T GOTO PR_BOOLEAN,PR_INTEGER,PR_UNKNOWN,PR_STRING_MAYBE,PR_SYMBOL,PR_SEQ,PR_SEQ,PR_SEQ,PR_FUNCTION,PR_MAL_FUNCTION,PR_MAL_FUNCTION,PR_ATOM,PR_ENV,PR_RECUR,PR_FREE
|
||||
|
||||
PR_UNKNOWN:
|
||||
R$="#<unknown>"
|
||||
RETURN
|
||||
PR_RECUR:
|
||||
AZ=Z%(AZ,1)
|
||||
GOTO PR_STR_RECUR
|
||||
PR_BOOLEAN:
|
||||
R$="true"
|
||||
IF Z%(AZ,1)=0 THEN R$="false"
|
||||
RETURN
|
||||
PR_INTEGER:
|
||||
T5=Z%(AZ,1)
|
||||
R$=STR$(T5)
|
||||
IF T5<0 THEN RETURN
|
||||
REM Remove initial space
|
||||
R$=RIGHT$(R$, LEN(R$)-1)
|
||||
RETURN
|
||||
PR_STRING_MAYBE:
|
||||
R$=S$(Z%(AZ,1))
|
||||
IF LEN(R$)=0 THEN GOTO PR_STRING
|
||||
IF MID$(R$,1,1)=CHR$(127) THEN R$=":"+MID$(R$,2,LEN(R$)-1):RETURN
|
||||
PR_STRING:
|
||||
IF PR=1 THEN PR_STRING_READABLY
|
||||
RETURN
|
||||
PR_STRING_READABLY:
|
||||
S1$=CHR$(92):S2$=CHR$(92)+CHR$(92):GOSUB REPLACE: REM escape backslash
|
||||
S1$=CHR$(34):S2$=CHR$(92)+CHR$(34):GOSUB REPLACE: REM escape quotes
|
||||
S1$=CHR$(13):S2$=CHR$(92)+"n":GOSUB REPLACE: REM escape newlines
|
||||
R$=CHR$(34)+R$+CHR$(34)
|
||||
RETURN
|
||||
PR_SYMBOL:
|
||||
R$=S$(Z%(AZ,1))
|
||||
RETURN
|
||||
PR_SEQ:
|
||||
IF T=6 THEN RR$=RR$+"("
|
||||
IF T=7 THEN RR$=RR$+"["
|
||||
IF T=8 THEN RR$=RR$+"{"
|
||||
REM push the type and where we are in the sequence
|
||||
X=X+2
|
||||
X%(X-1)=T
|
||||
X%(X)=AZ
|
||||
PR_SEQ_LOOP:
|
||||
IF Z%(AZ,1)=0 THEN PR_SEQ_DONE
|
||||
AZ=AZ+1
|
||||
GOSUB PR_STR_RECUR
|
||||
REM if we just rendered a non-sequence, then append it
|
||||
IF T<6 OR T>8 THEN RR$=RR$+R$
|
||||
REM restore current seq type
|
||||
T=X%(X-1)
|
||||
REM Go to next list element
|
||||
AZ=Z%(X%(X),1)
|
||||
X%(X)=AZ
|
||||
IF Z%(AZ,1)<>0 THEN RR$=RR$+" "
|
||||
GOTO PR_SEQ_LOOP
|
||||
PR_SEQ_DONE:
|
||||
REM get type
|
||||
T=X%(X-1)
|
||||
REM pop where we are the sequence and type
|
||||
X=X-2
|
||||
IF T=6 THEN RR$=RR$+")"
|
||||
IF T=7 THEN RR$=RR$+"]"
|
||||
IF T=8 THEN RR$=RR$+"}"
|
||||
R$=RR$
|
||||
RETURN
|
||||
PR_FUNCTION:
|
||||
T1=Z%(AZ,1)
|
||||
R$="#<function"+STR$(T1)+">"
|
||||
RETURN
|
||||
PR_MAL_FUNCTION:
|
||||
T1=AZ
|
||||
AZ=Z%(T1+1,0):GOSUB PR_STR_RECUR
|
||||
T7$="(fn* "+R$
|
||||
RR$=""
|
||||
AZ=Z%(T1,1):GOSUB PR_STR_RECUR
|
||||
R$=T7$+" "+R$+")"
|
||||
RETURN
|
||||
PR_ATOM:
|
||||
AZ=Z%(AZ,1):GOSUB PR_STR_RECUR
|
||||
R$="(atom "+R$+")"
|
||||
RETURN
|
||||
PR_ENV:
|
||||
R$="#<env"+STR$(AZ)+", data"+STR$(Z%(AZ,1))+">"
|
||||
RETURN
|
||||
PR_FREE:
|
||||
R$="#<free memory "+STR$(AZ)+", next"+STR$(Z%(AZ,1))+">"
|
||||
RETURN
|
||||
|
||||
REM PR_STR_SEQ(AZ, PR, SE$) -> R$
|
||||
PR_STR_SEQ:
|
||||
T9=AZ
|
||||
R1$=""
|
||||
PR_STR_SEQ_LOOP:
|
||||
IF Z%(T9,1)=0 THEN R$=R1$:RETURN
|
||||
AZ=T9+1:GOSUB PR_STR
|
||||
REM goto the next sequence element
|
||||
T9=Z%(T9,1)
|
||||
IF Z%(T9,1)=0 THEN R1$=R1$+R$
|
||||
IF Z%(T9,1)<>0 THEN R1$=R1$+R$+SE$
|
||||
GOTO PR_STR_SEQ_LOOP
|
253
basic/reader.in.bas
Normal file
253
basic/reader.in.bas
Normal file
@ -0,0 +1,253 @@
|
||||
REM READ_TOKEN(A$, RI, RF) -> T$
|
||||
READ_TOKEN:
|
||||
RJ=RI
|
||||
IF RF=1 THEN GOSUB READ_FILE_CHUNK
|
||||
REM PRINT "READ_TOKEN: "+STR$(RJ)+", "+MID$(A$,RJ,1)
|
||||
T$=MID$(A$,RJ,1)
|
||||
IF T$="(" OR T$=")" OR T$="[" OR T$="]" OR T$="{" OR T$="}" THEN RETURN
|
||||
IF T$="'" OR T$="`" OR T$="@" THEN RETURN
|
||||
IF T$="~" AND NOT MID$(A$,RJ+1,1)="@" THEN RETURN
|
||||
S1=0:S2=0: REM S1: INSTRING?, S2: ESCAPED?
|
||||
IF T$=CHR$(34) THEN S1=1
|
||||
RJ=RJ+1
|
||||
READ_TOKEN_LOOP:
|
||||
IF RF=1 THEN GOSUB READ_FILE_CHUNK
|
||||
IF RJ>LEN(A$) THEN RETURN
|
||||
CH$=MID$(A$,RJ,1)
|
||||
IF S2 THEN GOTO READ_TOKEN_CONT
|
||||
IF S1 THEN GOTO READ_TOKEN_CONT
|
||||
IF CH$=" " OR CH$="," THEN RETURN
|
||||
IF CH$=" " OR CH$="," OR CH$=CHR$(13) OR CH$=CHR$(10) THEN RETURN
|
||||
IF CH$="(" OR CH$=")" OR CH$="[" OR CH$="]" OR CH$="{" OR CH$="}" THEN RETURN
|
||||
READ_TOKEN_CONT:
|
||||
T$=T$+CH$
|
||||
IF T$="~@" THEN RETURN
|
||||
RJ=RJ+1
|
||||
IF S1 AND S2 THEN S2=0:GOTO READ_TOKEN_LOOP
|
||||
IF S1 AND S2=0 AND CH$=CHR$(92) THEN S2=1:GOTO READ_TOKEN_LOOP
|
||||
IF S1 AND S2=0 AND CH$=CHR$(34) THEN RETURN
|
||||
GOTO READ_TOKEN_LOOP
|
||||
|
||||
READ_FILE_CHUNK:
|
||||
IF RS=1 THEN RETURN
|
||||
IF RI>1 THEN A$=MID$(A$,RI,LEN(A$)-RI+1):RI=1:RJ=RJ-RI+1
|
||||
READ_FILE_CHUNK_LOOP:
|
||||
IF LEN(A$)>RJ+9 THEN RETURN
|
||||
#cbm GET#2,C$
|
||||
#qbasic C$=INPUT$(1,2)
|
||||
#qbasic IF EOF(2) THEN RS=1:A$=A$+CHR$(10)+")":RETURN
|
||||
A$=A$+C$
|
||||
#cbm IF (ST AND 64) THEN RS=1:A$=A$+CHR$(10)+")":RETURN
|
||||
#cbm IF (ST AND 255) THEN RS=1:ER=-1:ER$="File read error "+STR$(ST):RETURN
|
||||
GOTO READ_FILE_CHUNK_LOOP
|
||||
|
||||
SKIP_SPACES:
|
||||
IF RF=1 THEN GOSUB READ_FILE_CHUNK
|
||||
CH$=MID$(A$,RI,1)
|
||||
IF CH$<>" " AND CH$<>"," AND CH$<>CHR$(13) AND CH$<>CHR$(10) THEN RETURN
|
||||
RI=RI+1
|
||||
GOTO SKIP_SPACES
|
||||
|
||||
SKIP_TO_EOL:
|
||||
IF RF=1 THEN GOSUB READ_FILE_CHUNK
|
||||
CH$=MID$(A$,RI+1,1)
|
||||
RI=RI+1
|
||||
IF CH$="" OR CH$=CHR$(13) OR CH$=CHR$(10) THEN RETURN
|
||||
GOTO SKIP_TO_EOL
|
||||
|
||||
|
||||
READ_ATOM:
|
||||
R=0
|
||||
RETURN
|
||||
|
||||
REM READ_FORM(A$, RI, RF) -> R
|
||||
READ_FORM:
|
||||
IF ER<>-2 THEN RETURN
|
||||
GOSUB SKIP_SPACES
|
||||
GOSUB READ_TOKEN
|
||||
IF T$="" AND SD>0 THEN ER$="unexpected EOF":GOTO READ_FORM_ABORT
|
||||
REM PRINT "READ_FORM T$: ["+T$+"]"
|
||||
IF T$="" THEN R=0:GOTO READ_FORM_DONE
|
||||
IF T$="nil" THEN T=0:GOTO READ_NIL_BOOL
|
||||
IF T$="false" THEN T=1:GOTO READ_NIL_BOOL
|
||||
IF T$="true" THEN T=2:GOTO READ_NIL_BOOL
|
||||
IF T$="'" THEN AS$="quote":GOTO READ_MACRO
|
||||
IF T$="`" THEN AS$="quasiquote":GOTO READ_MACRO
|
||||
IF T$="~" THEN AS$="unquote":GOTO READ_MACRO
|
||||
IF T$="~@" THEN AS$="splice-unquote":GOTO READ_MACRO
|
||||
IF T$="^" THEN AS$="with-meta":GOTO READ_MACRO
|
||||
IF T$="@" THEN AS$="deref":GOTO READ_MACRO
|
||||
CH$=MID$(T$,1,1)
|
||||
REM PRINT "CH$: ["+CH$+"]("+STR$(ASC(CH$))+")"
|
||||
IF (CH$=";") THEN R=0:GOSUB SKIP_TO_EOL:GOTO READ_FORM
|
||||
IF CH$>="0" AND CH$<="9" THEN GOTO READ_NUMBER
|
||||
IF CH$="-" THEN GOTO READ_SYMBOL_MAYBE
|
||||
|
||||
IF CH$=CHR$(34) THEN GOTO READ_STRING
|
||||
IF CH$=":" THEN GOTO READ_KEYWORD
|
||||
IF CH$="(" THEN T=6:GOTO READ_SEQ
|
||||
IF CH$=")" THEN T=6:GOTO READ_SEQ_END
|
||||
IF CH$="[" THEN T=7:GOTO READ_SEQ
|
||||
IF CH$="]" THEN T=7:GOTO READ_SEQ_END
|
||||
IF CH$="{" THEN T=8:GOTO READ_SEQ
|
||||
IF CH$="}" THEN T=8:GOTO READ_SEQ_END
|
||||
GOTO READ_SYMBOL
|
||||
|
||||
READ_NIL_BOOL:
|
||||
REM PRINT "READ_NIL_BOOL"
|
||||
R=T
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO READ_FORM_DONE
|
||||
READ_NUMBER:
|
||||
REM PRINT "READ_NUMBER"
|
||||
T=2:L=VAL(T$):GOSUB ALLOC
|
||||
GOTO READ_FORM_DONE
|
||||
READ_MACRO:
|
||||
RI=RI+LEN(T$)
|
||||
REM to call READ_FORM recursively, SD needs to be saved, set to
|
||||
REM 0 for the call and then restored afterwards.
|
||||
X=X+2:X%(X-1)=(T$="^"):X%(X)=SD: REM push macro type and SD
|
||||
|
||||
REM AS$ is set above
|
||||
T=5:GOSUB STRING:X=X+1:X%(X)=R
|
||||
|
||||
SD=0:GOSUB READ_FORM:X=X+1:X%(X)=R
|
||||
|
||||
IF X%(X-3) THEN GOTO READ_MACRO_3
|
||||
|
||||
READ_MACRO_2:
|
||||
B2=X%(X-1):B1=X%(X):GOSUB LIST2
|
||||
GOTO READ_MACRO_DONE
|
||||
|
||||
READ_MACRO_3:
|
||||
SD=0:GOSUB READ_FORM
|
||||
B3=X%(X-1):B2=R:B1=X%(X):GOSUB LIST3
|
||||
AY=B3:GOSUB RELEASE
|
||||
|
||||
READ_MACRO_DONE:
|
||||
REM release values, list has ownership
|
||||
AY=B2:GOSUB RELEASE
|
||||
AY=B1:GOSUB RELEASE
|
||||
|
||||
SD=X%(X-2):X=X-4: REM get SD and pop the stack
|
||||
T$="": REM necessary to prevent unexpected EOF errors
|
||||
GOTO READ_FORM_DONE
|
||||
READ_STRING:
|
||||
REM PRINT "READ_STRING"
|
||||
T7$=MID$(T$,LEN(T$),1)
|
||||
IF T7$<>CHR$(34) THEN ER$="expected '"+CHR$(34)+"'":GOTO READ_FORM_ABORT
|
||||
R$=MID$(T$,2,LEN(T$)-2)
|
||||
S1$=CHR$(92)+CHR$(34):S2$=CHR$(34):GOSUB REPLACE: REM unescape quotes
|
||||
S1$=CHR$(92)+"n":S2$=CHR$(13):GOSUB REPLACE: REM unescape newlines
|
||||
S1$=CHR$(92)+CHR$(92):S2$=CHR$(92):GOSUB REPLACE: REM unescape backslashes
|
||||
REM intern string value
|
||||
AS$=R$:T=4:GOSUB STRING
|
||||
GOTO READ_FORM_DONE
|
||||
READ_KEYWORD:
|
||||
R$=CHR$(127)+MID$(T$,2,LEN(T$)-1)
|
||||
AS$=R$:T=4:GOSUB STRING
|
||||
GOTO READ_FORM_DONE
|
||||
READ_SYMBOL_MAYBE:
|
||||
CH$=MID$(T$,2,1)
|
||||
IF CH$>="0" AND CH$<="9" THEN GOTO READ_NUMBER
|
||||
READ_SYMBOL:
|
||||
REM PRINT "READ_SYMBOL"
|
||||
AS$=T$:T=5:GOSUB STRING
|
||||
GOTO READ_FORM_DONE
|
||||
|
||||
READ_SEQ:
|
||||
REM PRINT "READ_SEQ"
|
||||
SD=SD+1: REM increase read sequence depth
|
||||
|
||||
REM point to empty sequence to start off
|
||||
R=(T-5)*2+1: REM calculate location of empty seq
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
|
||||
REM push start ptr on the stack
|
||||
X=X+1
|
||||
X%(X)=R
|
||||
REM push current sequence type
|
||||
X=X+1
|
||||
X%(X)=T
|
||||
REM push previous ptr on the stack
|
||||
X=X+1
|
||||
X%(X)=R
|
||||
|
||||
RI=RI+LEN(T$)
|
||||
GOTO READ_FORM
|
||||
|
||||
READ_SEQ_END:
|
||||
REM PRINT "READ_SEQ_END"
|
||||
IF SD=0 THEN ER$="unexpected '"+CH$+"'":GOTO READ_FORM_ABORT
|
||||
IF X%(X-1)<>T THEN ER$="sequence mismatch":GOTO READ_FORM_ABORT
|
||||
SD=SD-1: REM decrease read sequence depth
|
||||
R=X%(X-2): REM ptr to start of sequence to return
|
||||
T=X%(X-1): REM type prior to recur
|
||||
X=X-3: REM pop start, type and previous off the stack
|
||||
GOTO READ_FORM_DONE
|
||||
|
||||
|
||||
READ_FORM_DONE:
|
||||
RI=RI+LEN(T$)
|
||||
|
||||
REM check read sequence depth
|
||||
IF SD=0 THEN RETURN
|
||||
|
||||
REM previous element
|
||||
T7=X%(X)
|
||||
|
||||
REM allocate new sequence entry, set type to previous type, set
|
||||
REM next to previous next or previous (if first)
|
||||
L=Z%(T7,1)
|
||||
IF T7<9 THEN L=T7
|
||||
T8=R: REM save previous value for release
|
||||
T=X%(X-1):N=R:GOSUB ALLOC
|
||||
REM list takes ownership
|
||||
IF L<9 THEN AY=L:GOSUB RELEASE
|
||||
AY=T8:GOSUB RELEASE
|
||||
|
||||
REM if previous element is the first element then set
|
||||
REM the first to the new element
|
||||
IF T7<9 THEN X%(X-2)=R:GOTO READ_FORM_SKIP_FIRST
|
||||
REM set previous list element to point to new element
|
||||
Z%(T7,1)=R
|
||||
|
||||
READ_FORM_SKIP_FIRST:
|
||||
|
||||
REM update previous pointer to current element
|
||||
X%(X)=R
|
||||
GOTO READ_FORM
|
||||
|
||||
READ_FORM_ABORT:
|
||||
ER=-1
|
||||
R=0
|
||||
READ_FORM_ABORT_UNWIND:
|
||||
IF SD=0 THEN RETURN
|
||||
X=X-3: REM pop previous, type, and start off the stack
|
||||
SD=SD-1
|
||||
IF SD=0 THEN AY=X%(X+1):GOSUB RELEASE
|
||||
GOTO READ_FORM_ABORT_UNWIND
|
||||
|
||||
|
||||
REM READ_STR(A$) -> R
|
||||
READ_STR:
|
||||
RI=1: REM index into A$
|
||||
RF=0: REM not reading from file
|
||||
SD=0: REM sequence read depth
|
||||
GOSUB READ_FORM
|
||||
RETURN
|
||||
|
||||
REM READ_FILE(A$) -> R
|
||||
READ_FILE:
|
||||
RI=1: REM index into A$
|
||||
RJ=1: REM READ_TOKEN sub-index
|
||||
RF=1: REM reading from file
|
||||
RS=0: REM file read state (1: EOF)
|
||||
SD=0: REM sequence read depth
|
||||
#cbm OPEN 2,8,0,A$
|
||||
#qbasic IF NOT _FILEEXISTS(A$) THEN ER=-1:ER$="File not found":RETURN
|
||||
#qbasic OPEN A$ FOR INPUT AS #2
|
||||
REM READ_FILE_CHUNK adds terminating ")"
|
||||
A$="(do ":GOSUB READ_FORM
|
||||
CLOSE 2
|
||||
RETURN
|
33
basic/readline.in.bas
Normal file
33
basic/readline.in.bas
Normal file
@ -0,0 +1,33 @@
|
||||
REM READLINE(A$) -> R$
|
||||
READLINE:
|
||||
EZ=0
|
||||
PROMPT$=A$
|
||||
PRINT PROMPT$;
|
||||
CH$="":LI$="":CH=0
|
||||
READCH:
|
||||
#cbm GET CH$
|
||||
#qbasic CH$=INKEY$
|
||||
IF CH$="" THEN GOTO READCH
|
||||
CH=ASC(CH$)
|
||||
REM PRINT CH
|
||||
#qbasic IF ASC(CH$)=8 THEN CH=20:CH$=CHR$(20)
|
||||
IF CH=4 OR CH=0 THEN EZ=1:GOTO RL_DONE: REM EOF
|
||||
IF CH=127 OR CH=20 THEN GOSUB RL_BACKSPACE
|
||||
IF CH=127 OR CH=20 THEN GOTO READCH
|
||||
IF (CH<32 OR CH>127) AND CH<>13 THEN GOTO READCH
|
||||
PRINT CH$;
|
||||
IF LEN(LI$)<255 AND CH$<>CHR$(13) THEN LI$=LI$+CH$
|
||||
IF LEN(LI$)<255 AND CH$<>CHR$(13) THEN GOTO READCH
|
||||
RL_DONE:
|
||||
R$=LI$
|
||||
RETURN
|
||||
|
||||
REM Assumes LI$ has input buffer
|
||||
RL_BACKSPACE:
|
||||
IF LEN(LI$)=0 THEN RETURN
|
||||
LI$=LEFT$(LI$, LEN(LI$)-1)
|
||||
#cbm PRINT CHR$(157)+" "+CHR$(157);
|
||||
#qbasic LOCATE ,POS(0)-1
|
||||
#qbasic PRINT " ";
|
||||
#qbasic LOCATE ,POS(0)-1
|
||||
RETURN
|
4
basic/run
Executable file
4
basic/run
Executable file
@ -0,0 +1,4 @@
|
||||
#!/bin/bash
|
||||
cd $(dirname $0)
|
||||
(echo "(list $(for a in "${@}"; do echo -n "\"${a}\""; done))") > .args.mal
|
||||
exec cbmbasic ${STEP:-stepA_mal}.bas "${@}"
|
41
basic/step0_repl.in.bas
Executable file
41
basic/step0_repl.in.bas
Executable file
@ -0,0 +1,41 @@
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
|
||||
REM READ(A$) -> R$
|
||||
MAL_READ:
|
||||
R$=A$
|
||||
RETURN
|
||||
|
||||
REM EVAL(A$, E) -> R$
|
||||
SUB EVAL
|
||||
R$=A$
|
||||
END SUB
|
||||
|
||||
REM PRINT(A$) -> R$
|
||||
MAL_PRINT:
|
||||
R$=A$
|
||||
RETURN
|
||||
|
||||
REM REP(A$) -> R$
|
||||
SUB REP
|
||||
GOSUB MAL_READ
|
||||
A=R:CALL EVAL
|
||||
A=R:GOSUB MAL_PRINT
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
REM PRINT "Free: "+STR$(FRE(0))
|
||||
END
|
||||
|
66
basic/step1_read_print.in.bas
Executable file
66
basic/step1_read_print.in.bas
Executable file
@ -0,0 +1,66 @@
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
REM $INCLUDE: 'types.in.bas'
|
||||
REM $INCLUDE: 'reader.in.bas'
|
||||
REM $INCLUDE: 'printer.in.bas'
|
||||
|
||||
REM $INCLUDE: 'debug.in.bas'
|
||||
|
||||
REM READ(A$) -> R
|
||||
MAL_READ:
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
|
||||
REM EVAL(A, E) -> R
|
||||
SUB EVAL
|
||||
R=A
|
||||
END SUB
|
||||
|
||||
REM PRINT(A) -> R$
|
||||
MAL_PRINT:
|
||||
AZ=A:PR=1:GOSUB PR_STR
|
||||
RETURN
|
||||
|
||||
REM REP(A$) -> R$
|
||||
SUB REP
|
||||
GOSUB MAL_READ
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:CALL EVAL
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:GOSUB MAL_PRINT
|
||||
RT$=R$
|
||||
|
||||
REP_DONE:
|
||||
REM Release memory from EVAL
|
||||
AY=R:GOSUB RELEASE
|
||||
R$=RT$
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
GOSUB INIT_MEMORY
|
||||
|
||||
ZT=ZI: REM top of memory after base repl_env
|
||||
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
REM GOSUB PR_MEMORY_SUMMARY
|
||||
END
|
||||
|
||||
PRINT_ERROR:
|
||||
PRINT "Error: "+ER$
|
||||
ER=-2:ER$=""
|
||||
RETURN
|
||||
|
274
basic/step2_eval.in.bas
Executable file
274
basic/step2_eval.in.bas
Executable file
@ -0,0 +1,274 @@
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
REM $INCLUDE: 'types.in.bas'
|
||||
REM $INCLUDE: 'reader.in.bas'
|
||||
REM $INCLUDE: 'printer.in.bas'
|
||||
|
||||
REM $INCLUDE: 'debug.in.bas'
|
||||
|
||||
REM READ(A$) -> R
|
||||
MAL_READ:
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
|
||||
REM EVAL_AST(A, E) -> R
|
||||
SUB EVAL_AST
|
||||
LV=LV+1
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_RETURN
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
T=Z%(A,0)AND 31
|
||||
IF T=5 THEN GOTO EVAL_AST_SYMBOL
|
||||
IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ
|
||||
|
||||
REM scalar: deref to actual value and inc ref cnt
|
||||
R=A:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SYMBOL:
|
||||
H=E:K=A:GOSUB HASHMAP_GET
|
||||
GOSUB DEREF_R
|
||||
IF T3=0 THEN ER=-1:ER$="'"+S$(Z%(A,1))+"' not found":GOTO EVAL_AST_RETURN
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SEQ:
|
||||
REM allocate the first entry (T already set above)
|
||||
L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM make space on the stack
|
||||
X=X+4
|
||||
REM push type of sequence
|
||||
X%(X-3)=T
|
||||
REM push sequence index
|
||||
X%(X-2)=-1
|
||||
REM push future return value (new sequence)
|
||||
X%(X-1)=R
|
||||
REM push previous new sequence entry
|
||||
X%(X)=R
|
||||
|
||||
EVAL_AST_SEQ_LOOP:
|
||||
REM update index
|
||||
X%(X-2)=X%(X-2)+1
|
||||
|
||||
REM check if we are done evaluating the source sequence
|
||||
IF Z%(A,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if hashmap, skip eval of even entries (keys)
|
||||
IF (X%(X-3)=8) AND ((X%(X-2)AND 1)=0) THEN GOTO EVAL_AST_DO_REF
|
||||
GOTO EVAL_AST_DO_EVAL
|
||||
|
||||
EVAL_AST_DO_REF:
|
||||
R=A+1:GOSUB DEREF_R: REM deref to target of referred entry
|
||||
Z%(R,0)=Z%(R,0)+32: REM inc ref cnt of referred value
|
||||
GOTO EVAL_AST_ADD_VALUE
|
||||
|
||||
EVAL_AST_DO_EVAL:
|
||||
REM call EVAL for each entry
|
||||
A=A+1:CALL EVAL
|
||||
A=A-1
|
||||
GOSUB DEREF_R: REM deref to target of evaluated entry
|
||||
|
||||
EVAL_AST_ADD_VALUE:
|
||||
|
||||
REM update previous value pointer to evaluated entry
|
||||
Z%(X%(X)+1,1)=R
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM allocate the next entry
|
||||
REM same new sequence entry type
|
||||
T=X%(X-3):L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM update previous sequence entry value to point to new entry
|
||||
Z%(X%(X),1)=R
|
||||
REM update previous ptr to current entry
|
||||
X%(X)=R
|
||||
|
||||
REM process the next sequence entry from source list
|
||||
A=Z%(A,1)
|
||||
|
||||
GOTO EVAL_AST_SEQ_LOOP
|
||||
EVAL_AST_SEQ_LOOP_DONE:
|
||||
REM get return value (new seq), index, and seq type
|
||||
R=X%(X-1)
|
||||
REM pop previous, return, index and type
|
||||
X=X-4
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_RETURN:
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
LV=LV-1
|
||||
END SUB
|
||||
|
||||
REM EVAL(A, E) -> R
|
||||
SUB EVAL
|
||||
LV=LV+1: REM track basic return stack level
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM AZ=A:PR=1:GOSUB PR_STR
|
||||
REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R THEN GOTO APPLY_LIST
|
||||
REM ELSE
|
||||
CALL EVAL_AST
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
APPLY_LIST:
|
||||
GOSUB EMPTY_Q
|
||||
IF R THEN R=A:Z%(R,0)=Z%(R,0)+32:GOTO EVAL_RETURN
|
||||
|
||||
EVAL_INVOKE:
|
||||
CALL EVAL_AST
|
||||
R3=R
|
||||
|
||||
REM if error, return f/args for release by caller
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
F=R+1
|
||||
|
||||
AR=Z%(R,1): REM rest
|
||||
R=F:GOSUB DEREF_R:F=R
|
||||
IF (Z%(F,0)AND 31)<>9 THEN ER=-1:ER$="apply of non-function":GOTO EVAL_RETURN
|
||||
GOSUB DO_FUNCTION
|
||||
AY=R3:GOSUB RELEASE
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_RETURN:
|
||||
|
||||
LV=LV-1: REM track basic return stack level
|
||||
|
||||
REM trigger GC
|
||||
#cbm TA=FRE(0)
|
||||
#qbasic TA=0
|
||||
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
END SUB
|
||||
|
||||
REM DO_FUNCTION(F, AR)
|
||||
DO_FUNCTION:
|
||||
AZ=F:GOSUB PR_STR
|
||||
F$=R$
|
||||
AZ=AR:GOSUB PR_STR
|
||||
AR$=R$
|
||||
|
||||
REM Get the function number
|
||||
FF=Z%(F,1)
|
||||
|
||||
REM Get argument values
|
||||
R=AR+1:GOSUB DEREF_R:AA=Z%(R,1)
|
||||
R=Z%(AR,1)+1:GOSUB DEREF_R:AB=Z%(R,1)
|
||||
|
||||
REM Switch on the function number
|
||||
IF FF=1 THEN GOTO DO_ADD
|
||||
IF FF=2 THEN GOTO DO_SUB
|
||||
IF FF=3 THEN GOTO DO_MULT
|
||||
IF FF=4 THEN GOTO DO_DIV
|
||||
ER=-1:ER$="unknown function"+STR$(FF):RETURN
|
||||
|
||||
DO_ADD:
|
||||
T=2:L=AA+AB:GOSUB ALLOC
|
||||
GOTO DO_FUNCTION_DONE
|
||||
DO_SUB:
|
||||
T=2:L=AA-AB:GOSUB ALLOC
|
||||
GOTO DO_FUNCTION_DONE
|
||||
DO_MULT:
|
||||
T=2:L=AA*AB:GOSUB ALLOC
|
||||
GOTO DO_FUNCTION_DONE
|
||||
DO_DIV:
|
||||
T=2:L=AA/AB:GOSUB ALLOC
|
||||
GOTO DO_FUNCTION_DONE
|
||||
|
||||
DO_FUNCTION_DONE:
|
||||
RETURN
|
||||
|
||||
REM PRINT(A) -> R$
|
||||
MAL_PRINT:
|
||||
AZ=A:PR=1:GOSUB PR_STR
|
||||
RETURN
|
||||
|
||||
REM REP(A$) -> R$
|
||||
REM Assume D has repl_env
|
||||
SUB REP
|
||||
R1=0:R2=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
R2=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:GOSUB MAL_PRINT
|
||||
RT$=R$
|
||||
|
||||
REP_DONE:
|
||||
REM Release memory from MAL_READ and EVAL
|
||||
IF R2<>0 THEN AY=R2:GOSUB RELEASE
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
R$=RT$
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
GOSUB INIT_MEMORY
|
||||
|
||||
LV=0
|
||||
|
||||
REM create repl_env
|
||||
GOSUB HASHMAP:D=R
|
||||
|
||||
REM + function
|
||||
A=1:GOSUB NATIVE_FUNCTION
|
||||
H=D:K$="+":V=R:GOSUB ASSOC1_S:D=R
|
||||
|
||||
REM - function
|
||||
A=2:GOSUB NATIVE_FUNCTION
|
||||
H=D:K$="-":V=R:GOSUB ASSOC1_S:D=R
|
||||
|
||||
REM * function
|
||||
A=3:GOSUB NATIVE_FUNCTION
|
||||
H=D:K$="*":V=R:GOSUB ASSOC1_S:D=R
|
||||
|
||||
REM / function
|
||||
A=4:GOSUB NATIVE_FUNCTION
|
||||
H=D:K$="/":V=R:GOSUB ASSOC1_S:D=R
|
||||
|
||||
ZT=ZI: REM top of memory after base repl_env
|
||||
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
REM GOSUB PR_MEMORY_SUMMARY
|
||||
END
|
||||
|
||||
PRINT_ERROR:
|
||||
PRINT "Error: "+ER$
|
||||
ER=-2:ER$=""
|
||||
RETURN
|
||||
|
348
basic/step3_env.in.bas
Executable file
348
basic/step3_env.in.bas
Executable file
@ -0,0 +1,348 @@
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
REM $INCLUDE: 'types.in.bas'
|
||||
REM $INCLUDE: 'reader.in.bas'
|
||||
REM $INCLUDE: 'printer.in.bas'
|
||||
REM $INCLUDE: 'env.in.bas'
|
||||
|
||||
REM $INCLUDE: 'debug.in.bas'
|
||||
|
||||
REM READ(A$) -> R
|
||||
MAL_READ:
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
|
||||
REM EVAL_AST(A, E) -> R
|
||||
SUB EVAL_AST
|
||||
LV=LV+1
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_RETURN
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
T=Z%(A,0)AND 31
|
||||
IF T=5 THEN GOTO EVAL_AST_SYMBOL
|
||||
IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ
|
||||
|
||||
REM scalar: deref to actual value and inc ref cnt
|
||||
R=A:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SYMBOL:
|
||||
K=A:GOTO ENV_GET
|
||||
ENV_GET_RETURN:
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SEQ:
|
||||
REM allocate the first entry (T already set above)
|
||||
L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM make space on the stack
|
||||
X=X+4
|
||||
REM push type of sequence
|
||||
X%(X-3)=T
|
||||
REM push sequence index
|
||||
X%(X-2)=-1
|
||||
REM push future return value (new sequence)
|
||||
X%(X-1)=R
|
||||
REM push previous new sequence entry
|
||||
X%(X)=R
|
||||
|
||||
EVAL_AST_SEQ_LOOP:
|
||||
REM update index
|
||||
X%(X-2)=X%(X-2)+1
|
||||
|
||||
REM check if we are done evaluating the source sequence
|
||||
IF Z%(A,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if hashmap, skip eval of even entries (keys)
|
||||
IF (X%(X-3)=8) AND ((X%(X-2)AND 1)=0) THEN GOTO EVAL_AST_DO_REF
|
||||
GOTO EVAL_AST_DO_EVAL
|
||||
|
||||
EVAL_AST_DO_REF:
|
||||
R=A+1:GOSUB DEREF_R: REM deref to target of referred entry
|
||||
Z%(R,0)=Z%(R,0)+32: REM inc ref cnt of referred value
|
||||
GOTO EVAL_AST_ADD_VALUE
|
||||
|
||||
EVAL_AST_DO_EVAL:
|
||||
REM call EVAL for each entry
|
||||
A=A+1:CALL EVAL
|
||||
A=A-1
|
||||
GOSUB DEREF_R: REM deref to target of evaluated entry
|
||||
|
||||
EVAL_AST_ADD_VALUE:
|
||||
|
||||
REM update previous value pointer to evaluated entry
|
||||
Z%(X%(X)+1,1)=R
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM allocate the next entry
|
||||
REM same new sequence entry type
|
||||
T=X%(X-3):L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM update previous sequence entry value to point to new entry
|
||||
Z%(X%(X),1)=R
|
||||
REM update previous ptr to current entry
|
||||
X%(X)=R
|
||||
|
||||
REM process the next sequence entry from source list
|
||||
A=Z%(A,1)
|
||||
|
||||
GOTO EVAL_AST_SEQ_LOOP
|
||||
EVAL_AST_SEQ_LOOP_DONE:
|
||||
REM if no error, get return value (new seq)
|
||||
IF ER=-2 THEN R=X%(X-1)
|
||||
REM otherwise, free the return value and return nil
|
||||
IF ER<>-2 THEN R=0:AY=X%(X-1):GOSUB RELEASE
|
||||
|
||||
REM pop previous, return, index and type
|
||||
X=X-4
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_RETURN:
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
LV=LV-1
|
||||
END SUB
|
||||
|
||||
REM EVAL(A, E) -> R
|
||||
SUB EVAL
|
||||
LV=LV+1: REM track basic return stack level
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM AZ=A:PR=1:GOSUB PR_STR
|
||||
REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R THEN GOTO APPLY_LIST
|
||||
REM ELSE
|
||||
CALL EVAL_AST
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
APPLY_LIST:
|
||||
GOSUB EMPTY_Q
|
||||
IF R THEN R=A:Z%(R,0)=Z%(R,0)+32:GOTO EVAL_RETURN
|
||||
|
||||
A0=A+1
|
||||
R=A0:GOSUB DEREF_R:A0=R
|
||||
|
||||
REM get symbol in A$
|
||||
IF (Z%(A0,0)AND 31)<>5 THEN A$=""
|
||||
IF (Z%(A0,0)AND 31)=5 THEN A$=S$(Z%(A0,1))
|
||||
|
||||
IF A$="def!" THEN GOTO EVAL_DEF
|
||||
IF A$="let*" THEN GOTO EVAL_LET
|
||||
GOTO EVAL_INVOKE
|
||||
|
||||
EVAL_GET_A3:
|
||||
A3=Z%(Z%(Z%(A,1),1),1)+1
|
||||
R=A3:GOSUB DEREF_R:A3=R
|
||||
EVAL_GET_A2:
|
||||
A2=Z%(Z%(A,1),1)+1
|
||||
R=A2:GOSUB DEREF_R:A2=R
|
||||
EVAL_GET_A1:
|
||||
A1=Z%(A,1)+1
|
||||
R=A1:GOSUB DEREF_R:A1=R
|
||||
RETURN
|
||||
|
||||
EVAL_DEF:
|
||||
REM PRINT "def!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval a2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM set a1 in env to a2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_LET:
|
||||
REM PRINT "let*"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A2: REM push/save A2
|
||||
REM create new environment with outer as current environment
|
||||
O=E:GOSUB ENV_NEW
|
||||
E=R
|
||||
EVAL_LET_LOOP:
|
||||
IF Z%(A1,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
REM eval current A1 odd element
|
||||
A=Z%(A1,1)+1:CALL EVAL
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
REM set environment: even A1 key to odd A1 eval'd above
|
||||
K=A1+1:V=R:GOSUB ENV_SET
|
||||
AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership
|
||||
|
||||
REM skip to the next pair of A1 elements
|
||||
A1=Z%(Z%(A1,1),1)
|
||||
GOTO EVAL_LET_LOOP
|
||||
|
||||
EVAL_LET_LOOP_DONE:
|
||||
A2=X%(X):X=X-1: REM pop A2
|
||||
A=A2:CALL EVAL: REM eval A2 using let_env
|
||||
GOTO EVAL_RETURN
|
||||
EVAL_INVOKE:
|
||||
CALL EVAL_AST
|
||||
R3=R
|
||||
|
||||
REM if error, return f/args for release by caller
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
F=R+1
|
||||
|
||||
AR=Z%(R,1): REM rest
|
||||
R=F:GOSUB DEREF_R:F=R
|
||||
IF (Z%(F,0)AND 31)<>9 THEN ER=-1:ER$="apply of non-function":GOTO EVAL_RETURN
|
||||
GOSUB DO_FUNCTION
|
||||
AY=R3:GOSUB RELEASE
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_RETURN:
|
||||
REM AZ=R: PR=1: GOSUB PR_STR
|
||||
REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER)
|
||||
|
||||
REM release environment if not the top one on the stack
|
||||
IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
|
||||
|
||||
LV=LV-1: REM track basic return stack level
|
||||
|
||||
REM trigger GC
|
||||
#cbm TA=FRE(0)
|
||||
#qbasic TA=0
|
||||
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
END SUB
|
||||
|
||||
REM DO_FUNCTION(F, AR)
|
||||
DO_FUNCTION:
|
||||
AZ=F:GOSUB PR_STR
|
||||
F$=R$
|
||||
AZ=AR:GOSUB PR_STR
|
||||
AR$=R$
|
||||
|
||||
REM Get the function number
|
||||
FF=Z%(F,1)
|
||||
|
||||
REM Get argument values
|
||||
R=AR+1:GOSUB DEREF_R:AA=Z%(R,1)
|
||||
R=Z%(AR,1)+1:GOSUB DEREF_R:AB=Z%(R,1)
|
||||
|
||||
REM Switch on the function number
|
||||
IF FF=1 THEN GOTO DO_ADD
|
||||
IF FF=2 THEN GOTO DO_SUB
|
||||
IF FF=3 THEN GOTO DO_MULT
|
||||
IF FF=4 THEN GOTO DO_DIV
|
||||
ER=-1:ER$="unknown function"+STR$(FF):RETURN
|
||||
|
||||
DO_ADD:
|
||||
T=2:L=AA+AB:GOSUB ALLOC
|
||||
GOTO DO_FUNCTION_DONE
|
||||
DO_SUB:
|
||||
T=2:L=AA-AB:GOSUB ALLOC
|
||||
GOTO DO_FUNCTION_DONE
|
||||
DO_MULT:
|
||||
T=2:L=AA*AB:GOSUB ALLOC
|
||||
GOTO DO_FUNCTION_DONE
|
||||
DO_DIV:
|
||||
T=2:L=AA/AB:GOSUB ALLOC
|
||||
GOTO DO_FUNCTION_DONE
|
||||
|
||||
DO_FUNCTION_DONE:
|
||||
RETURN
|
||||
|
||||
REM PRINT(A) -> R$
|
||||
MAL_PRINT:
|
||||
AZ=A:PR=1:GOSUB PR_STR
|
||||
RETURN
|
||||
|
||||
REM REP(A$) -> R$
|
||||
REM Assume D has repl_env
|
||||
SUB REP
|
||||
R1=0:R2=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
R2=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:GOSUB MAL_PRINT
|
||||
RT$=R$
|
||||
|
||||
REP_DONE:
|
||||
REM Release memory from MAL_READ and EVAL
|
||||
IF R2<>0 THEN AY=R2:GOSUB RELEASE
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
R$=RT$
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
GOSUB INIT_MEMORY
|
||||
|
||||
LV=0
|
||||
|
||||
REM create repl_env
|
||||
O=-1:GOSUB ENV_NEW:D=R
|
||||
|
||||
E=D
|
||||
REM + function
|
||||
A=1:GOSUB NATIVE_FUNCTION
|
||||
K$="+":V=R:GOSUB ENV_SET_S
|
||||
|
||||
REM - function
|
||||
A=2:GOSUB NATIVE_FUNCTION
|
||||
K$="-":V=R:GOSUB ENV_SET_S
|
||||
|
||||
REM * function
|
||||
A=3:GOSUB NATIVE_FUNCTION
|
||||
K$="*":V=R:GOSUB ENV_SET_S
|
||||
|
||||
REM / function
|
||||
A=4:GOSUB NATIVE_FUNCTION
|
||||
K$="/":V=R:GOSUB ENV_SET_S
|
||||
|
||||
ZT=ZI: REM top of memory after base repl_env
|
||||
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
REM GOSUB PR_MEMORY_SUMMARY
|
||||
END
|
||||
|
||||
PRINT_ERROR:
|
||||
PRINT "Error: "+ER$
|
||||
ER=-2:ER$=""
|
||||
RETURN
|
||||
|
404
basic/step4_if_fn_do.in.bas
Executable file
404
basic/step4_if_fn_do.in.bas
Executable file
@ -0,0 +1,404 @@
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
REM $INCLUDE: 'types.in.bas'
|
||||
REM $INCLUDE: 'reader.in.bas'
|
||||
REM $INCLUDE: 'printer.in.bas'
|
||||
REM $INCLUDE: 'env.in.bas'
|
||||
REM $INCLUDE: 'core.in.bas'
|
||||
|
||||
REM $INCLUDE: 'debug.in.bas'
|
||||
|
||||
REM READ(A$) -> R
|
||||
MAL_READ:
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
|
||||
REM EVAL_AST(A, E) -> R
|
||||
SUB EVAL_AST
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_RETURN
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
T=Z%(A,0)AND 31
|
||||
IF T=5 THEN GOTO EVAL_AST_SYMBOL
|
||||
IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ
|
||||
|
||||
REM scalar: deref to actual value and inc ref cnt
|
||||
R=A:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SYMBOL:
|
||||
K=A:GOTO ENV_GET
|
||||
ENV_GET_RETURN:
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SEQ:
|
||||
REM allocate the first entry (T already set above)
|
||||
L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM make space on the stack
|
||||
X=X+4
|
||||
REM push type of sequence
|
||||
X%(X-3)=T
|
||||
REM push sequence index
|
||||
X%(X-2)=-1
|
||||
REM push future return value (new sequence)
|
||||
X%(X-1)=R
|
||||
REM push previous new sequence entry
|
||||
X%(X)=R
|
||||
|
||||
EVAL_AST_SEQ_LOOP:
|
||||
REM update index
|
||||
X%(X-2)=X%(X-2)+1
|
||||
|
||||
REM check if we are done evaluating the source sequence
|
||||
IF Z%(A,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if hashmap, skip eval of even entries (keys)
|
||||
IF (X%(X-3)=8) AND ((X%(X-2)AND 1)=0) THEN GOTO EVAL_AST_DO_REF
|
||||
GOTO EVAL_AST_DO_EVAL
|
||||
|
||||
EVAL_AST_DO_REF:
|
||||
R=A+1:GOSUB DEREF_R: REM deref to target of referred entry
|
||||
Z%(R,0)=Z%(R,0)+32: REM inc ref cnt of referred value
|
||||
GOTO EVAL_AST_ADD_VALUE
|
||||
|
||||
EVAL_AST_DO_EVAL:
|
||||
REM call EVAL for each entry
|
||||
A=A+1:CALL EVAL
|
||||
A=A-1
|
||||
GOSUB DEREF_R: REM deref to target of evaluated entry
|
||||
|
||||
EVAL_AST_ADD_VALUE:
|
||||
|
||||
REM update previous value pointer to evaluated entry
|
||||
Z%(X%(X)+1,1)=R
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM allocate the next entry
|
||||
REM same new sequence entry type
|
||||
T=X%(X-3):L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM update previous sequence entry value to point to new entry
|
||||
Z%(X%(X),1)=R
|
||||
REM update previous ptr to current entry
|
||||
X%(X)=R
|
||||
|
||||
REM process the next sequence entry from source list
|
||||
A=Z%(A,1)
|
||||
|
||||
GOTO EVAL_AST_SEQ_LOOP
|
||||
EVAL_AST_SEQ_LOOP_DONE:
|
||||
REM if no error, get return value (new seq)
|
||||
IF ER=-2 THEN R=X%(X-1)
|
||||
REM otherwise, free the return value and return nil
|
||||
IF ER<>-2 THEN R=0:AY=X%(X-1):GOSUB RELEASE
|
||||
|
||||
REM pop previous, return, index and type
|
||||
X=X-4
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_RETURN:
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
END SUB
|
||||
|
||||
REM EVAL(A, E) -> R
|
||||
SUB EVAL
|
||||
LV=LV+1: REM track basic return stack level
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0))
|
||||
|
||||
EVAL_TCO_RECUR:
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM AZ=A:PR=1:GOSUB PR_STR
|
||||
REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R THEN GOTO APPLY_LIST
|
||||
REM ELSE
|
||||
CALL EVAL_AST
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
APPLY_LIST:
|
||||
GOSUB EMPTY_Q
|
||||
IF R THEN R=A:Z%(R,0)=Z%(R,0)+32:GOTO EVAL_RETURN
|
||||
|
||||
A0=A+1
|
||||
R=A0:GOSUB DEREF_R:A0=R
|
||||
|
||||
REM get symbol in A$
|
||||
IF (Z%(A0,0)AND 31)<>5 THEN A$=""
|
||||
IF (Z%(A0,0)AND 31)=5 THEN A$=S$(Z%(A0,1))
|
||||
|
||||
IF A$="def!" THEN GOTO EVAL_DEF
|
||||
IF A$="let*" THEN GOTO EVAL_LET
|
||||
IF A$="do" THEN GOTO EVAL_DO
|
||||
IF A$="if" THEN GOTO EVAL_IF
|
||||
IF A$="fn*" THEN GOTO EVAL_FN
|
||||
GOTO EVAL_INVOKE
|
||||
|
||||
EVAL_GET_A3:
|
||||
A3=Z%(Z%(Z%(A,1),1),1)+1
|
||||
R=A3:GOSUB DEREF_R:A3=R
|
||||
EVAL_GET_A2:
|
||||
A2=Z%(Z%(A,1),1)+1
|
||||
R=A2:GOSUB DEREF_R:A2=R
|
||||
EVAL_GET_A1:
|
||||
A1=Z%(A,1)+1
|
||||
R=A1:GOSUB DEREF_R:A1=R
|
||||
RETURN
|
||||
|
||||
EVAL_DEF:
|
||||
REM PRINT "def!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval a2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM set a1 in env to a2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_LET:
|
||||
REM PRINT "let*"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A2: REM push/save A2
|
||||
REM create new environment with outer as current environment
|
||||
O=E:GOSUB ENV_NEW
|
||||
E=R
|
||||
EVAL_LET_LOOP:
|
||||
IF Z%(A1,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
REM eval current A1 odd element
|
||||
A=Z%(A1,1)+1:CALL EVAL
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
REM set environment: even A1 key to odd A1 eval'd above
|
||||
K=A1+1:V=R:GOSUB ENV_SET
|
||||
AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership
|
||||
|
||||
REM skip to the next pair of A1 elements
|
||||
A1=Z%(Z%(A1,1),1)
|
||||
GOTO EVAL_LET_LOOP
|
||||
|
||||
EVAL_LET_LOOP_DONE:
|
||||
A2=X%(X):X=X-1: REM pop A2
|
||||
A=A2:CALL EVAL: REM eval A2 using let_env
|
||||
GOTO EVAL_RETURN
|
||||
EVAL_DO:
|
||||
A=Z%(A,1): REM rest
|
||||
|
||||
CALL EVAL_AST
|
||||
|
||||
X=X+1:X%(X)=R: REM push eval'd list
|
||||
A=R:GOSUB LAST: REM return the last element
|
||||
AY=X%(X):X=X-1: REM pop eval'd list
|
||||
GOSUB RELEASE: REM release the eval'd list
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_IF:
|
||||
GOSUB EVAL_GET_A1: REM set A1
|
||||
REM push A
|
||||
X=X+1:X%(X)=A
|
||||
A=A1:CALL EVAL
|
||||
REM pop A
|
||||
A=X%(X):X=X-1
|
||||
IF (R=0) OR (R=1) THEN GOTO EVAL_IF_FALSE
|
||||
|
||||
EVAL_IF_TRUE:
|
||||
AY=R:GOSUB RELEASE
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
EVAL_IF_FALSE:
|
||||
AY=R:GOSUB RELEASE
|
||||
REM if no false case (A3), return nil
|
||||
B=A:GOSUB COUNT
|
||||
IF R<4 THEN R=0:GOTO EVAL_RETURN
|
||||
GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL
|
||||
A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_FN:
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
A=A2:P=A1:GOSUB MAL_FUNCTION
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_INVOKE:
|
||||
CALL EVAL_AST
|
||||
|
||||
REM if error, return f/args for release by caller
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM push f/args for release after call
|
||||
X=X+1:X%(X)=R
|
||||
|
||||
F=R+1
|
||||
|
||||
AR=Z%(R,1): REM rest
|
||||
R=F:GOSUB DEREF_R:F=R
|
||||
|
||||
REM if metadata, get the actual object
|
||||
IF (Z%(F,0)AND 31)>=16 THEN F=Z%(F,1)
|
||||
|
||||
IF (Z%(F,0)AND 31)=9 THEN GOTO EVAL_DO_FUNCTION
|
||||
IF (Z%(F,0)AND 31)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
|
||||
|
||||
REM if error, pop and return f/args for release by caller
|
||||
R=X%(X):X=X-1
|
||||
ER=-1:ER$="apply of non-function":GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_FUNCTION:
|
||||
REM regular function
|
||||
IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
|
||||
REM for recur functions (apply, map, swap!), use GOTO
|
||||
IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
|
||||
EVAL_DO_FUNCTION_SKIP:
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_MAL_FUNCTION:
|
||||
E4=E: REM save the current environment for release
|
||||
|
||||
REM create new environ using env stored with function
|
||||
O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
|
||||
|
||||
REM release previous env if it is not the top one on the
|
||||
REM stack (X%(X-2)) because our new env refers to it and
|
||||
REM we no longer need to track it (since we are TCO recurring)
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
REM claim the AST before releasing the list containing it
|
||||
A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
|
||||
REM add AST to pending release queue to free as soon as EVAL
|
||||
REM actually returns (LV+1)
|
||||
Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV+1
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
|
||||
REM A set above
|
||||
E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_RETURN:
|
||||
REM AZ=R: PR=1: GOSUB PR_STR
|
||||
REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER)
|
||||
|
||||
REM release environment if not the top one on the stack
|
||||
IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
|
||||
|
||||
LV=LV-1: REM track basic return stack level
|
||||
|
||||
REM release everything we couldn't release earlier
|
||||
GOSUB RELEASE_PEND
|
||||
|
||||
REM trigger GC
|
||||
#cbm TA=FRE(0)
|
||||
#qbasic TA=0
|
||||
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
END SUB
|
||||
|
||||
REM PRINT(A) -> R$
|
||||
MAL_PRINT:
|
||||
AZ=A:PR=1:GOSUB PR_STR
|
||||
RETURN
|
||||
|
||||
REM RE(A$) -> R
|
||||
REM Assume D has repl_env
|
||||
REM caller must release result
|
||||
RE:
|
||||
R1=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO RE_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
|
||||
RE_DONE:
|
||||
REM Release memory from MAL_READ
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
RETURN: REM caller must release result of EVAL
|
||||
|
||||
REM REP(A$) -> R$
|
||||
REM Assume D has repl_env
|
||||
SUB REP
|
||||
R1=0:R2=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
R2=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:GOSUB MAL_PRINT
|
||||
RT$=R$
|
||||
|
||||
REP_DONE:
|
||||
REM Release memory from MAL_READ and EVAL
|
||||
IF R2<>0 THEN AY=R2:GOSUB RELEASE
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
R$=RT$
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
GOSUB INIT_MEMORY
|
||||
|
||||
LV=0
|
||||
|
||||
REM create repl_env
|
||||
O=-1:GOSUB ENV_NEW:D=R
|
||||
|
||||
REM core.EXT: defined in Basic
|
||||
E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
|
||||
|
||||
ZT=ZI: REM top of memory after base repl_env
|
||||
|
||||
REM core.mal: defined using the language itself
|
||||
A$="(def! not (fn* (a) (if a false true)))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
REM GOSUB PR_MEMORY_SUMMARY
|
||||
END
|
||||
|
||||
PRINT_ERROR:
|
||||
PRINT "Error: "+ER$
|
||||
ER=-2:ER$=""
|
||||
RETURN
|
||||
|
422
basic/step5_tco.in.bas
Executable file
422
basic/step5_tco.in.bas
Executable file
@ -0,0 +1,422 @@
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
REM $INCLUDE: 'types.in.bas'
|
||||
REM $INCLUDE: 'reader.in.bas'
|
||||
REM $INCLUDE: 'printer.in.bas'
|
||||
REM $INCLUDE: 'env.in.bas'
|
||||
REM $INCLUDE: 'core.in.bas'
|
||||
|
||||
REM $INCLUDE: 'debug.in.bas'
|
||||
|
||||
REM READ(A$) -> R
|
||||
MAL_READ:
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
|
||||
REM EVAL_AST(A, E) -> R
|
||||
SUB EVAL_AST
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_RETURN
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
T=Z%(A,0)AND 31
|
||||
IF T=5 THEN GOTO EVAL_AST_SYMBOL
|
||||
IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ
|
||||
|
||||
REM scalar: deref to actual value and inc ref cnt
|
||||
R=A:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SYMBOL:
|
||||
K=A:GOTO ENV_GET
|
||||
ENV_GET_RETURN:
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SEQ:
|
||||
REM allocate the first entry (T already set above)
|
||||
L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM make space on the stack
|
||||
X=X+4
|
||||
REM push type of sequence
|
||||
X%(X-3)=T
|
||||
REM push sequence index
|
||||
X%(X-2)=-1
|
||||
REM push future return value (new sequence)
|
||||
X%(X-1)=R
|
||||
REM push previous new sequence entry
|
||||
X%(X)=R
|
||||
|
||||
EVAL_AST_SEQ_LOOP:
|
||||
REM update index
|
||||
X%(X-2)=X%(X-2)+1
|
||||
|
||||
REM check if we are done evaluating the source sequence
|
||||
IF Z%(A,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if we are returning to DO, then skip last element
|
||||
IF X%(X-6)=2 AND Z%(Z%(A,1),1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if hashmap, skip eval of even entries (keys)
|
||||
IF (X%(X-3)=8) AND ((X%(X-2)AND 1)=0) THEN GOTO EVAL_AST_DO_REF
|
||||
GOTO EVAL_AST_DO_EVAL
|
||||
|
||||
EVAL_AST_DO_REF:
|
||||
R=A+1:GOSUB DEREF_R: REM deref to target of referred entry
|
||||
Z%(R,0)=Z%(R,0)+32: REM inc ref cnt of referred value
|
||||
GOTO EVAL_AST_ADD_VALUE
|
||||
|
||||
EVAL_AST_DO_EVAL:
|
||||
REM call EVAL for each entry
|
||||
A=A+1:CALL EVAL
|
||||
A=A-1
|
||||
GOSUB DEREF_R: REM deref to target of evaluated entry
|
||||
|
||||
EVAL_AST_ADD_VALUE:
|
||||
|
||||
REM update previous value pointer to evaluated entry
|
||||
Z%(X%(X)+1,1)=R
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM allocate the next entry
|
||||
REM same new sequence entry type
|
||||
T=X%(X-3):L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM update previous sequence entry value to point to new entry
|
||||
Z%(X%(X),1)=R
|
||||
REM update previous ptr to current entry
|
||||
X%(X)=R
|
||||
|
||||
REM process the next sequence entry from source list
|
||||
A=Z%(A,1)
|
||||
|
||||
GOTO EVAL_AST_SEQ_LOOP
|
||||
EVAL_AST_SEQ_LOOP_DONE:
|
||||
REM if no error, get return value (new seq)
|
||||
IF ER=-2 THEN R=X%(X-1)
|
||||
REM otherwise, free the return value and return nil
|
||||
IF ER<>-2 THEN R=0:AY=X%(X-1):GOSUB RELEASE
|
||||
|
||||
REM pop previous, return, index and type
|
||||
X=X-4
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_RETURN:
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
END SUB
|
||||
|
||||
REM EVAL(A, E) -> R
|
||||
SUB EVAL
|
||||
LV=LV+1: REM track basic return stack level
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0))
|
||||
|
||||
EVAL_TCO_RECUR:
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM AZ=A:PR=1:GOSUB PR_STR
|
||||
REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R THEN GOTO APPLY_LIST
|
||||
REM ELSE
|
||||
CALL EVAL_AST
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
APPLY_LIST:
|
||||
GOSUB EMPTY_Q
|
||||
IF R THEN R=A:Z%(R,0)=Z%(R,0)+32:GOTO EVAL_RETURN
|
||||
|
||||
A0=A+1
|
||||
R=A0:GOSUB DEREF_R:A0=R
|
||||
|
||||
REM get symbol in A$
|
||||
IF (Z%(A0,0)AND 31)<>5 THEN A$=""
|
||||
IF (Z%(A0,0)AND 31)=5 THEN A$=S$(Z%(A0,1))
|
||||
|
||||
IF A$="def!" THEN GOTO EVAL_DEF
|
||||
IF A$="let*" THEN GOTO EVAL_LET
|
||||
IF A$="do" THEN GOTO EVAL_DO
|
||||
IF A$="if" THEN GOTO EVAL_IF
|
||||
IF A$="fn*" THEN GOTO EVAL_FN
|
||||
GOTO EVAL_INVOKE
|
||||
|
||||
EVAL_GET_A3:
|
||||
A3=Z%(Z%(Z%(A,1),1),1)+1
|
||||
R=A3:GOSUB DEREF_R:A3=R
|
||||
EVAL_GET_A2:
|
||||
A2=Z%(Z%(A,1),1)+1
|
||||
R=A2:GOSUB DEREF_R:A2=R
|
||||
EVAL_GET_A1:
|
||||
A1=Z%(A,1)+1
|
||||
R=A1:GOSUB DEREF_R:A1=R
|
||||
RETURN
|
||||
|
||||
EVAL_DEF:
|
||||
REM PRINT "def!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval a2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM set a1 in env to a2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_LET:
|
||||
REM PRINT "let*"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A2: REM push/save A2
|
||||
X=X+1:X%(X)=E: REM push env for for later release
|
||||
|
||||
REM create new environment with outer as current environment
|
||||
O=E:GOSUB ENV_NEW
|
||||
E=R
|
||||
EVAL_LET_LOOP:
|
||||
IF Z%(A1,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
REM eval current A1 odd element
|
||||
A=Z%(A1,1)+1:CALL EVAL
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
REM set environment: even A1 key to odd A1 eval'd above
|
||||
K=A1+1:V=R:GOSUB ENV_SET
|
||||
AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership
|
||||
|
||||
REM skip to the next pair of A1 elements
|
||||
A1=Z%(Z%(A1,1),1)
|
||||
GOTO EVAL_LET_LOOP
|
||||
|
||||
EVAL_LET_LOOP_DONE:
|
||||
E4=X%(X):X=X-1: REM pop previous env
|
||||
|
||||
REM release previous environment if not the current EVAL env
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
A2=X%(X):X=X-1: REM pop A2
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_DO:
|
||||
A=Z%(A,1): REM rest
|
||||
X=X+1:X%(X)=A: REM push/save A
|
||||
|
||||
CALL EVAL_AST
|
||||
|
||||
REM cleanup
|
||||
AY=R: REM get eval'd list for release
|
||||
|
||||
A=X%(X):X=X-1: REM pop/restore original A for LAST
|
||||
GOSUB LAST: REM get last element for return
|
||||
A=R: REM new recur AST
|
||||
|
||||
REM cleanup
|
||||
GOSUB RELEASE: REM release eval'd list
|
||||
AY=A:GOSUB RELEASE: REM release LAST value (not sure why)
|
||||
|
||||
GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_IF:
|
||||
GOSUB EVAL_GET_A1: REM set A1
|
||||
REM push A
|
||||
X=X+1:X%(X)=A
|
||||
A=A1:CALL EVAL
|
||||
REM pop A
|
||||
A=X%(X):X=X-1
|
||||
IF (R=0) OR (R=1) THEN GOTO EVAL_IF_FALSE
|
||||
|
||||
EVAL_IF_TRUE:
|
||||
AY=R:GOSUB RELEASE
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
EVAL_IF_FALSE:
|
||||
AY=R:GOSUB RELEASE
|
||||
REM if no false case (A3), return nil
|
||||
B=A:GOSUB COUNT
|
||||
IF R<4 THEN R=0:GOTO EVAL_RETURN
|
||||
GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL
|
||||
A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_FN:
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
A=A2:P=A1:GOSUB MAL_FUNCTION
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_INVOKE:
|
||||
CALL EVAL_AST
|
||||
|
||||
REM if error, return f/args for release by caller
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM push f/args for release after call
|
||||
X=X+1:X%(X)=R
|
||||
|
||||
F=R+1
|
||||
|
||||
AR=Z%(R,1): REM rest
|
||||
R=F:GOSUB DEREF_R:F=R
|
||||
|
||||
REM if metadata, get the actual object
|
||||
IF (Z%(F,0)AND 31)>=16 THEN F=Z%(F,1)
|
||||
|
||||
IF (Z%(F,0)AND 31)=9 THEN GOTO EVAL_DO_FUNCTION
|
||||
IF (Z%(F,0)AND 31)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
|
||||
|
||||
REM if error, pop and return f/args for release by caller
|
||||
R=X%(X):X=X-1
|
||||
ER=-1:ER$="apply of non-function":GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_FUNCTION:
|
||||
REM regular function
|
||||
IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
|
||||
REM for recur functions (apply, map, swap!), use GOTO
|
||||
IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
|
||||
EVAL_DO_FUNCTION_SKIP:
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_MAL_FUNCTION:
|
||||
E4=E: REM save the current environment for release
|
||||
|
||||
REM create new environ using env stored with function
|
||||
O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
|
||||
|
||||
REM release previous env if it is not the top one on the
|
||||
REM stack (X%(X-2)) because our new env refers to it and
|
||||
REM we no longer need to track it (since we are TCO recurring)
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
REM claim the AST before releasing the list containing it
|
||||
A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
|
||||
REM add AST to pending release queue to free as soon as EVAL
|
||||
REM actually returns (LV+1)
|
||||
Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV+1
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
|
||||
REM A set above
|
||||
E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_RETURN:
|
||||
REM AZ=R: PR=1: GOSUB PR_STR
|
||||
REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER)
|
||||
|
||||
REM release environment if not the top one on the stack
|
||||
IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
|
||||
|
||||
LV=LV-1: REM track basic return stack level
|
||||
|
||||
REM release everything we couldn't release earlier
|
||||
GOSUB RELEASE_PEND
|
||||
|
||||
REM trigger GC
|
||||
#cbm TA=FRE(0)
|
||||
#qbasic TA=0
|
||||
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
END SUB
|
||||
|
||||
REM PRINT(A) -> R$
|
||||
MAL_PRINT:
|
||||
AZ=A:PR=1:GOSUB PR_STR
|
||||
RETURN
|
||||
|
||||
REM RE(A$) -> R
|
||||
REM Assume D has repl_env
|
||||
REM caller must release result
|
||||
RE:
|
||||
R1=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO RE_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
|
||||
RE_DONE:
|
||||
REM Release memory from MAL_READ
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
RETURN: REM caller must release result of EVAL
|
||||
|
||||
REM REP(A$) -> R$
|
||||
REM Assume D has repl_env
|
||||
SUB REP
|
||||
R1=0:R2=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
R2=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:GOSUB MAL_PRINT
|
||||
RT$=R$
|
||||
|
||||
REP_DONE:
|
||||
REM Release memory from MAL_READ and EVAL
|
||||
IF R2<>0 THEN AY=R2:GOSUB RELEASE
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
R$=RT$
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
GOSUB INIT_MEMORY
|
||||
|
||||
LV=0
|
||||
|
||||
REM create repl_env
|
||||
O=-1:GOSUB ENV_NEW:D=R
|
||||
|
||||
REM core.EXT: defined in Basic
|
||||
E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
|
||||
|
||||
ZT=ZI: REM top of memory after base repl_env
|
||||
|
||||
REM core.mal: defined using the language itself
|
||||
A$="(def! not (fn* (a) (if a false true)))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
REM GOSUB PR_MEMORY_SUMMARY
|
||||
END
|
||||
|
||||
PRINT_ERROR:
|
||||
PRINT "Error: "+ER$
|
||||
ER=-2:ER$=""
|
||||
RETURN
|
||||
|
449
basic/step6_file.in.bas
Executable file
449
basic/step6_file.in.bas
Executable file
@ -0,0 +1,449 @@
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
REM $INCLUDE: 'types.in.bas'
|
||||
REM $INCLUDE: 'reader.in.bas'
|
||||
REM $INCLUDE: 'printer.in.bas'
|
||||
REM $INCLUDE: 'env.in.bas'
|
||||
REM $INCLUDE: 'core.in.bas'
|
||||
|
||||
REM $INCLUDE: 'debug.in.bas'
|
||||
|
||||
REM READ(A$) -> R
|
||||
MAL_READ:
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
|
||||
REM EVAL_AST(A, E) -> R
|
||||
SUB EVAL_AST
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_RETURN
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
T=Z%(A,0)AND 31
|
||||
IF T=5 THEN GOTO EVAL_AST_SYMBOL
|
||||
IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ
|
||||
|
||||
REM scalar: deref to actual value and inc ref cnt
|
||||
R=A:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SYMBOL:
|
||||
K=A:GOTO ENV_GET
|
||||
ENV_GET_RETURN:
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SEQ:
|
||||
REM allocate the first entry (T already set above)
|
||||
L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM make space on the stack
|
||||
X=X+4
|
||||
REM push type of sequence
|
||||
X%(X-3)=T
|
||||
REM push sequence index
|
||||
X%(X-2)=-1
|
||||
REM push future return value (new sequence)
|
||||
X%(X-1)=R
|
||||
REM push previous new sequence entry
|
||||
X%(X)=R
|
||||
|
||||
EVAL_AST_SEQ_LOOP:
|
||||
REM update index
|
||||
X%(X-2)=X%(X-2)+1
|
||||
|
||||
REM check if we are done evaluating the source sequence
|
||||
IF Z%(A,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if we are returning to DO, then skip last element
|
||||
IF X%(X-6)=2 AND Z%(Z%(A,1),1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if hashmap, skip eval of even entries (keys)
|
||||
IF (X%(X-3)=8) AND ((X%(X-2)AND 1)=0) THEN GOTO EVAL_AST_DO_REF
|
||||
GOTO EVAL_AST_DO_EVAL
|
||||
|
||||
EVAL_AST_DO_REF:
|
||||
R=A+1:GOSUB DEREF_R: REM deref to target of referred entry
|
||||
Z%(R,0)=Z%(R,0)+32: REM inc ref cnt of referred value
|
||||
GOTO EVAL_AST_ADD_VALUE
|
||||
|
||||
EVAL_AST_DO_EVAL:
|
||||
REM call EVAL for each entry
|
||||
A=A+1:CALL EVAL
|
||||
A=A-1
|
||||
GOSUB DEREF_R: REM deref to target of evaluated entry
|
||||
|
||||
EVAL_AST_ADD_VALUE:
|
||||
|
||||
REM update previous value pointer to evaluated entry
|
||||
Z%(X%(X)+1,1)=R
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM allocate the next entry
|
||||
REM same new sequence entry type
|
||||
T=X%(X-3):L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM update previous sequence entry value to point to new entry
|
||||
Z%(X%(X),1)=R
|
||||
REM update previous ptr to current entry
|
||||
X%(X)=R
|
||||
|
||||
REM process the next sequence entry from source list
|
||||
A=Z%(A,1)
|
||||
|
||||
GOTO EVAL_AST_SEQ_LOOP
|
||||
EVAL_AST_SEQ_LOOP_DONE:
|
||||
REM if no error, get return value (new seq)
|
||||
IF ER=-2 THEN R=X%(X-1)
|
||||
REM otherwise, free the return value and return nil
|
||||
IF ER<>-2 THEN R=0:AY=X%(X-1):GOSUB RELEASE
|
||||
|
||||
REM pop previous, return, index and type
|
||||
X=X-4
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_RETURN:
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
END SUB
|
||||
|
||||
REM EVAL(A, E) -> R
|
||||
SUB EVAL
|
||||
LV=LV+1: REM track basic return stack level
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0))
|
||||
|
||||
EVAL_TCO_RECUR:
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM AZ=A:PR=1:GOSUB PR_STR
|
||||
REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R THEN GOTO APPLY_LIST
|
||||
REM ELSE
|
||||
CALL EVAL_AST
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
APPLY_LIST:
|
||||
GOSUB EMPTY_Q
|
||||
IF R THEN R=A:Z%(R,0)=Z%(R,0)+32:GOTO EVAL_RETURN
|
||||
|
||||
A0=A+1
|
||||
R=A0:GOSUB DEREF_R:A0=R
|
||||
|
||||
REM get symbol in A$
|
||||
IF (Z%(A0,0)AND 31)<>5 THEN A$=""
|
||||
IF (Z%(A0,0)AND 31)=5 THEN A$=S$(Z%(A0,1))
|
||||
|
||||
IF A$="def!" THEN GOTO EVAL_DEF
|
||||
IF A$="let*" THEN GOTO EVAL_LET
|
||||
IF A$="do" THEN GOTO EVAL_DO
|
||||
IF A$="if" THEN GOTO EVAL_IF
|
||||
IF A$="fn*" THEN GOTO EVAL_FN
|
||||
GOTO EVAL_INVOKE
|
||||
|
||||
EVAL_GET_A3:
|
||||
A3=Z%(Z%(Z%(A,1),1),1)+1
|
||||
R=A3:GOSUB DEREF_R:A3=R
|
||||
EVAL_GET_A2:
|
||||
A2=Z%(Z%(A,1),1)+1
|
||||
R=A2:GOSUB DEREF_R:A2=R
|
||||
EVAL_GET_A1:
|
||||
A1=Z%(A,1)+1
|
||||
R=A1:GOSUB DEREF_R:A1=R
|
||||
RETURN
|
||||
|
||||
EVAL_DEF:
|
||||
REM PRINT "def!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval a2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM set a1 in env to a2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_LET:
|
||||
REM PRINT "let*"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A2: REM push/save A2
|
||||
X=X+1:X%(X)=E: REM push env for for later release
|
||||
|
||||
REM create new environment with outer as current environment
|
||||
O=E:GOSUB ENV_NEW
|
||||
E=R
|
||||
EVAL_LET_LOOP:
|
||||
IF Z%(A1,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
REM eval current A1 odd element
|
||||
A=Z%(A1,1)+1:CALL EVAL
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
REM set environment: even A1 key to odd A1 eval'd above
|
||||
K=A1+1:V=R:GOSUB ENV_SET
|
||||
AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership
|
||||
|
||||
REM skip to the next pair of A1 elements
|
||||
A1=Z%(Z%(A1,1),1)
|
||||
GOTO EVAL_LET_LOOP
|
||||
|
||||
EVAL_LET_LOOP_DONE:
|
||||
E4=X%(X):X=X-1: REM pop previous env
|
||||
|
||||
REM release previous environment if not the current EVAL env
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
A2=X%(X):X=X-1: REM pop A2
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_DO:
|
||||
A=Z%(A,1): REM rest
|
||||
X=X+1:X%(X)=A: REM push/save A
|
||||
|
||||
CALL EVAL_AST
|
||||
|
||||
REM cleanup
|
||||
AY=R: REM get eval'd list for release
|
||||
|
||||
A=X%(X):X=X-1: REM pop/restore original A for LAST
|
||||
GOSUB LAST: REM get last element for return
|
||||
A=R: REM new recur AST
|
||||
|
||||
REM cleanup
|
||||
GOSUB RELEASE: REM release eval'd list
|
||||
AY=A:GOSUB RELEASE: REM release LAST value (not sure why)
|
||||
|
||||
GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_IF:
|
||||
GOSUB EVAL_GET_A1: REM set A1
|
||||
REM push A
|
||||
X=X+1:X%(X)=A
|
||||
A=A1:CALL EVAL
|
||||
REM pop A
|
||||
A=X%(X):X=X-1
|
||||
IF (R=0) OR (R=1) THEN GOTO EVAL_IF_FALSE
|
||||
|
||||
EVAL_IF_TRUE:
|
||||
AY=R:GOSUB RELEASE
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
EVAL_IF_FALSE:
|
||||
AY=R:GOSUB RELEASE
|
||||
REM if no false case (A3), return nil
|
||||
B=A:GOSUB COUNT
|
||||
IF R<4 THEN R=0:GOTO EVAL_RETURN
|
||||
GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL
|
||||
A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_FN:
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
A=A2:P=A1:GOSUB MAL_FUNCTION
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_INVOKE:
|
||||
CALL EVAL_AST
|
||||
|
||||
REM if error, return f/args for release by caller
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM push f/args for release after call
|
||||
X=X+1:X%(X)=R
|
||||
|
||||
F=R+1
|
||||
|
||||
AR=Z%(R,1): REM rest
|
||||
R=F:GOSUB DEREF_R:F=R
|
||||
|
||||
REM if metadata, get the actual object
|
||||
IF (Z%(F,0)AND 31)>=16 THEN F=Z%(F,1)
|
||||
|
||||
IF (Z%(F,0)AND 31)=9 THEN GOTO EVAL_DO_FUNCTION
|
||||
IF (Z%(F,0)AND 31)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
|
||||
|
||||
REM if error, pop and return f/args for release by caller
|
||||
R=X%(X):X=X-1
|
||||
ER=-1:ER$="apply of non-function":GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_FUNCTION:
|
||||
REM regular function
|
||||
IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
|
||||
REM for recur functions (apply, map, swap!), use GOTO
|
||||
IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
|
||||
EVAL_DO_FUNCTION_SKIP:
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_MAL_FUNCTION:
|
||||
E4=E: REM save the current environment for release
|
||||
|
||||
REM create new environ using env stored with function
|
||||
O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
|
||||
|
||||
REM release previous env if it is not the top one on the
|
||||
REM stack (X%(X-2)) because our new env refers to it and
|
||||
REM we no longer need to track it (since we are TCO recurring)
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
REM claim the AST before releasing the list containing it
|
||||
A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
|
||||
REM add AST to pending release queue to free as soon as EVAL
|
||||
REM actually returns (LV+1)
|
||||
Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV+1
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
|
||||
REM A set above
|
||||
E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_RETURN:
|
||||
REM AZ=R: PR=1: GOSUB PR_STR
|
||||
REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER)
|
||||
|
||||
REM release environment if not the top one on the stack
|
||||
IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
|
||||
|
||||
LV=LV-1: REM track basic return stack level
|
||||
|
||||
REM release everything we couldn't release earlier
|
||||
GOSUB RELEASE_PEND
|
||||
|
||||
REM trigger GC
|
||||
#cbm TA=FRE(0)
|
||||
#qbasic TA=0
|
||||
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
END SUB
|
||||
|
||||
REM PRINT(A) -> R$
|
||||
MAL_PRINT:
|
||||
AZ=A:PR=1:GOSUB PR_STR
|
||||
RETURN
|
||||
|
||||
REM RE(A$) -> R
|
||||
REM Assume D has repl_env
|
||||
REM caller must release result
|
||||
RE:
|
||||
R1=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO RE_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
|
||||
RE_DONE:
|
||||
REM Release memory from MAL_READ
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
RETURN: REM caller must release result of EVAL
|
||||
|
||||
REM REP(A$) -> R$
|
||||
REM Assume D has repl_env
|
||||
SUB REP
|
||||
R1=0:R2=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
R2=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:GOSUB MAL_PRINT
|
||||
RT$=R$
|
||||
|
||||
REP_DONE:
|
||||
REM Release memory from MAL_READ and EVAL
|
||||
IF R2<>0 THEN AY=R2:GOSUB RELEASE
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
R$=RT$
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
GOSUB INIT_MEMORY
|
||||
|
||||
LV=0
|
||||
|
||||
REM create repl_env
|
||||
O=-1:GOSUB ENV_NEW:D=R
|
||||
|
||||
REM core.EXT: defined in Basic
|
||||
E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
|
||||
|
||||
ZT=ZI: REM top of memory after base repl_env
|
||||
|
||||
REM core.mal: defined using the language itself
|
||||
A$="(def! not (fn* (a) (if a false true)))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(def! load-file (fn* (f) (eval (read-file f))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM load the args file
|
||||
A$="(def! -*ARGS*- (load-file "+CHR$(34)+".args.mal"+CHR$(34)+"))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM set the argument list
|
||||
A$="(def! *ARGV* (rest -*ARGS*-))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM get the first argument
|
||||
A$="(first -*ARGS*-)"
|
||||
GOSUB RE
|
||||
|
||||
REM if there is an argument, then run it as a program
|
||||
IF R<>0 THEN AY=R:GOSUB RELEASE:GOTO RUN_PROG
|
||||
REM no arguments, start REPL loop
|
||||
IF R=0 THEN GOTO REPL_LOOP
|
||||
|
||||
RUN_PROG:
|
||||
REM run a single mal program and exit
|
||||
A$="(load-file (first -*ARGS*-))"
|
||||
GOSUB RE
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR
|
||||
GOTO QUIT
|
||||
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
REM GOSUB PR_MEMORY_SUMMARY
|
||||
END
|
||||
|
||||
PRINT_ERROR:
|
||||
PRINT "Error: "+ER$
|
||||
ER=-2:ER$=""
|
||||
RETURN
|
||||
|
540
basic/step7_quote.in.bas
Executable file
540
basic/step7_quote.in.bas
Executable file
@ -0,0 +1,540 @@
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
REM $INCLUDE: 'types.in.bas'
|
||||
REM $INCLUDE: 'reader.in.bas'
|
||||
REM $INCLUDE: 'printer.in.bas'
|
||||
REM $INCLUDE: 'env.in.bas'
|
||||
REM $INCLUDE: 'core.in.bas'
|
||||
|
||||
REM $INCLUDE: 'debug.in.bas'
|
||||
|
||||
REM READ(A$) -> R
|
||||
MAL_READ:
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
|
||||
REM QUASIQUOTE(A) -> R
|
||||
SUB QUASIQUOTE
|
||||
REM pair?
|
||||
IF (Z%(A,0)AND 31)<6 OR (Z%(A,0)AND 31)>7 THEN GOTO QQ_QUOTE
|
||||
IF (Z%(A,1)=0) THEN GOTO QQ_QUOTE
|
||||
GOTO QQ_UNQUOTE
|
||||
|
||||
QQ_QUOTE:
|
||||
REM ['quote, ast]
|
||||
AS$="quote":T=5:GOSUB STRING
|
||||
B2=R:B1=A:GOSUB LIST2
|
||||
AY=B2:GOSUB RELEASE
|
||||
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_UNQUOTE:
|
||||
R=A+1:GOSUB DEREF_R
|
||||
IF (Z%(R,0)AND 31)<>5 THEN GOTO QQ_SPLICE_UNQUOTE
|
||||
IF S$(Z%(R,1))<>"unquote" THEN GOTO QQ_SPLICE_UNQUOTE
|
||||
REM [ast[1]]
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_SPLICE_UNQUOTE:
|
||||
REM push A on the stack
|
||||
X=X+1:X%(X)=A
|
||||
REM rest of cases call quasiquote on ast[1..]
|
||||
A=Z%(A,1):CALL QUASIQUOTE
|
||||
T6=R
|
||||
REM pop A off the stack
|
||||
A=X%(X):X=X-1
|
||||
|
||||
REM set A to ast[0] for last two cases
|
||||
A=A+1:GOSUB DEREF_A
|
||||
|
||||
REM pair?
|
||||
IF (Z%(A,0)AND 31)<6 OR (Z%(A,0)AND 31)>7 THEN GOTO QQ_DEFAULT
|
||||
IF (Z%(A,1)=0) THEN GOTO QQ_DEFAULT
|
||||
|
||||
B=A+1:GOSUB DEREF_B
|
||||
IF (Z%(B,0)AND 31)<>5 THEN GOTO QQ_DEFAULT
|
||||
IF S$(Z%(B,1))<>"splice-unquote" THEN QQ_DEFAULT
|
||||
REM ['concat, ast[0][1], quasiquote(ast[1..])]
|
||||
|
||||
B=Z%(A,1)+1:GOSUB DEREF_B:B2=B
|
||||
AS$="concat":T=5:GOSUB STRING:B3=R
|
||||
B1=T6:GOSUB LIST3
|
||||
REM release inner quasiquoted since outer list takes ownership
|
||||
AY=B1:GOSUB RELEASE
|
||||
AY=B3:GOSUB RELEASE
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_DEFAULT:
|
||||
REM ['cons, quasiquote(ast[0]), quasiquote(ast[1..])]
|
||||
|
||||
REM push T6 on the stack
|
||||
X=X+1:X%(X)=T6
|
||||
REM A set above to ast[0]
|
||||
CALL QUASIQUOTE
|
||||
B2=R
|
||||
REM pop T6 off the stack
|
||||
T6=X%(X):X=X-1
|
||||
|
||||
AS$="cons":T=5:GOSUB STRING:B3=R
|
||||
B1=T6:GOSUB LIST3
|
||||
REM release inner quasiquoted since outer list takes ownership
|
||||
AY=B1:GOSUB RELEASE
|
||||
AY=B2:GOSUB RELEASE
|
||||
AY=B3:GOSUB RELEASE
|
||||
QQ_DONE:
|
||||
END SUB
|
||||
|
||||
|
||||
REM EVAL_AST(A, E) -> R
|
||||
SUB EVAL_AST
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_RETURN
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
T=Z%(A,0)AND 31
|
||||
IF T=5 THEN GOTO EVAL_AST_SYMBOL
|
||||
IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ
|
||||
|
||||
REM scalar: deref to actual value and inc ref cnt
|
||||
R=A:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SYMBOL:
|
||||
K=A:GOTO ENV_GET
|
||||
ENV_GET_RETURN:
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SEQ:
|
||||
REM allocate the first entry (T already set above)
|
||||
L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM make space on the stack
|
||||
X=X+4
|
||||
REM push type of sequence
|
||||
X%(X-3)=T
|
||||
REM push sequence index
|
||||
X%(X-2)=-1
|
||||
REM push future return value (new sequence)
|
||||
X%(X-1)=R
|
||||
REM push previous new sequence entry
|
||||
X%(X)=R
|
||||
|
||||
EVAL_AST_SEQ_LOOP:
|
||||
REM update index
|
||||
X%(X-2)=X%(X-2)+1
|
||||
|
||||
REM check if we are done evaluating the source sequence
|
||||
IF Z%(A,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if we are returning to DO, then skip last element
|
||||
IF X%(X-6)=2 AND Z%(Z%(A,1),1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if hashmap, skip eval of even entries (keys)
|
||||
IF (X%(X-3)=8) AND ((X%(X-2)AND 1)=0) THEN GOTO EVAL_AST_DO_REF
|
||||
GOTO EVAL_AST_DO_EVAL
|
||||
|
||||
EVAL_AST_DO_REF:
|
||||
R=A+1:GOSUB DEREF_R: REM deref to target of referred entry
|
||||
Z%(R,0)=Z%(R,0)+32: REM inc ref cnt of referred value
|
||||
GOTO EVAL_AST_ADD_VALUE
|
||||
|
||||
EVAL_AST_DO_EVAL:
|
||||
REM call EVAL for each entry
|
||||
A=A+1:CALL EVAL
|
||||
A=A-1
|
||||
GOSUB DEREF_R: REM deref to target of evaluated entry
|
||||
|
||||
EVAL_AST_ADD_VALUE:
|
||||
|
||||
REM update previous value pointer to evaluated entry
|
||||
Z%(X%(X)+1,1)=R
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM allocate the next entry
|
||||
REM same new sequence entry type
|
||||
T=X%(X-3):L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM update previous sequence entry value to point to new entry
|
||||
Z%(X%(X),1)=R
|
||||
REM update previous ptr to current entry
|
||||
X%(X)=R
|
||||
|
||||
REM process the next sequence entry from source list
|
||||
A=Z%(A,1)
|
||||
|
||||
GOTO EVAL_AST_SEQ_LOOP
|
||||
EVAL_AST_SEQ_LOOP_DONE:
|
||||
REM if no error, get return value (new seq)
|
||||
IF ER=-2 THEN R=X%(X-1)
|
||||
REM otherwise, free the return value and return nil
|
||||
IF ER<>-2 THEN R=0:AY=X%(X-1):GOSUB RELEASE
|
||||
|
||||
REM pop previous, return, index and type
|
||||
X=X-4
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_RETURN:
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
END SUB
|
||||
|
||||
REM EVAL(A, E) -> R
|
||||
SUB EVAL
|
||||
LV=LV+1: REM track basic return stack level
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0))
|
||||
|
||||
EVAL_TCO_RECUR:
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM AZ=A:PR=1:GOSUB PR_STR
|
||||
REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R THEN GOTO APPLY_LIST
|
||||
REM ELSE
|
||||
CALL EVAL_AST
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
APPLY_LIST:
|
||||
GOSUB EMPTY_Q
|
||||
IF R THEN R=A:Z%(R,0)=Z%(R,0)+32:GOTO EVAL_RETURN
|
||||
|
||||
A0=A+1
|
||||
R=A0:GOSUB DEREF_R:A0=R
|
||||
|
||||
REM get symbol in A$
|
||||
IF (Z%(A0,0)AND 31)<>5 THEN A$=""
|
||||
IF (Z%(A0,0)AND 31)=5 THEN A$=S$(Z%(A0,1))
|
||||
|
||||
IF A$="def!" THEN GOTO EVAL_DEF
|
||||
IF A$="let*" THEN GOTO EVAL_LET
|
||||
IF A$="quote" THEN GOTO EVAL_QUOTE
|
||||
IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE
|
||||
IF A$="do" THEN GOTO EVAL_DO
|
||||
IF A$="if" THEN GOTO EVAL_IF
|
||||
IF A$="fn*" THEN GOTO EVAL_FN
|
||||
GOTO EVAL_INVOKE
|
||||
|
||||
EVAL_GET_A3:
|
||||
A3=Z%(Z%(Z%(A,1),1),1)+1
|
||||
R=A3:GOSUB DEREF_R:A3=R
|
||||
EVAL_GET_A2:
|
||||
A2=Z%(Z%(A,1),1)+1
|
||||
R=A2:GOSUB DEREF_R:A2=R
|
||||
EVAL_GET_A1:
|
||||
A1=Z%(A,1)+1
|
||||
R=A1:GOSUB DEREF_R:A1=R
|
||||
RETURN
|
||||
|
||||
EVAL_DEF:
|
||||
REM PRINT "def!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval a2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM set a1 in env to a2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_LET:
|
||||
REM PRINT "let*"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A2: REM push/save A2
|
||||
X=X+1:X%(X)=E: REM push env for for later release
|
||||
|
||||
REM create new environment with outer as current environment
|
||||
O=E:GOSUB ENV_NEW
|
||||
E=R
|
||||
EVAL_LET_LOOP:
|
||||
IF Z%(A1,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
REM eval current A1 odd element
|
||||
A=Z%(A1,1)+1:CALL EVAL
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
REM set environment: even A1 key to odd A1 eval'd above
|
||||
K=A1+1:V=R:GOSUB ENV_SET
|
||||
AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership
|
||||
|
||||
REM skip to the next pair of A1 elements
|
||||
A1=Z%(Z%(A1,1),1)
|
||||
GOTO EVAL_LET_LOOP
|
||||
|
||||
EVAL_LET_LOOP_DONE:
|
||||
E4=X%(X):X=X-1: REM pop previous env
|
||||
|
||||
REM release previous environment if not the current EVAL env
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
A2=X%(X):X=X-1: REM pop A2
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_DO:
|
||||
A=Z%(A,1): REM rest
|
||||
X=X+1:X%(X)=A: REM push/save A
|
||||
|
||||
CALL EVAL_AST
|
||||
|
||||
REM cleanup
|
||||
AY=R: REM get eval'd list for release
|
||||
|
||||
A=X%(X):X=X-1: REM pop/restore original A for LAST
|
||||
GOSUB LAST: REM get last element for return
|
||||
A=R: REM new recur AST
|
||||
|
||||
REM cleanup
|
||||
GOSUB RELEASE: REM release eval'd list
|
||||
AY=A:GOSUB RELEASE: REM release LAST value (not sure why)
|
||||
|
||||
GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_QUOTE:
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_QUASIQUOTE:
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
A=R:CALL QUASIQUOTE
|
||||
REM add quasiquote result to pending release queue to free when
|
||||
REM next lower EVAL level returns (LV)
|
||||
Y=Y+1:Y%(Y,0)=R:Y%(Y,1)=LV
|
||||
|
||||
A=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_IF:
|
||||
GOSUB EVAL_GET_A1: REM set A1
|
||||
REM push A
|
||||
X=X+1:X%(X)=A
|
||||
A=A1:CALL EVAL
|
||||
REM pop A
|
||||
A=X%(X):X=X-1
|
||||
IF (R=0) OR (R=1) THEN GOTO EVAL_IF_FALSE
|
||||
|
||||
EVAL_IF_TRUE:
|
||||
AY=R:GOSUB RELEASE
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
EVAL_IF_FALSE:
|
||||
AY=R:GOSUB RELEASE
|
||||
REM if no false case (A3), return nil
|
||||
B=A:GOSUB COUNT
|
||||
IF R<4 THEN R=0:GOTO EVAL_RETURN
|
||||
GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL
|
||||
A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_FN:
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
A=A2:P=A1:GOSUB MAL_FUNCTION
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_INVOKE:
|
||||
CALL EVAL_AST
|
||||
|
||||
REM if error, return f/args for release by caller
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM push f/args for release after call
|
||||
X=X+1:X%(X)=R
|
||||
|
||||
F=R+1
|
||||
|
||||
AR=Z%(R,1): REM rest
|
||||
R=F:GOSUB DEREF_R:F=R
|
||||
|
||||
REM if metadata, get the actual object
|
||||
IF (Z%(F,0)AND 31)>=16 THEN F=Z%(F,1)
|
||||
|
||||
IF (Z%(F,0)AND 31)=9 THEN GOTO EVAL_DO_FUNCTION
|
||||
IF (Z%(F,0)AND 31)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
|
||||
|
||||
REM if error, pop and return f/args for release by caller
|
||||
R=X%(X):X=X-1
|
||||
ER=-1:ER$="apply of non-function":GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_FUNCTION:
|
||||
REM regular function
|
||||
IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
|
||||
REM for recur functions (apply, map, swap!), use GOTO
|
||||
IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
|
||||
EVAL_DO_FUNCTION_SKIP:
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_MAL_FUNCTION:
|
||||
E4=E: REM save the current environment for release
|
||||
|
||||
REM create new environ using env stored with function
|
||||
O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
|
||||
|
||||
REM release previous env if it is not the top one on the
|
||||
REM stack (X%(X-2)) because our new env refers to it and
|
||||
REM we no longer need to track it (since we are TCO recurring)
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
REM claim the AST before releasing the list containing it
|
||||
A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
|
||||
REM add AST to pending release queue to free as soon as EVAL
|
||||
REM actually returns (LV+1)
|
||||
Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV+1
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
|
||||
REM A set above
|
||||
E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_RETURN:
|
||||
REM AZ=R: PR=1: GOSUB PR_STR
|
||||
REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER)
|
||||
|
||||
REM release environment if not the top one on the stack
|
||||
IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
|
||||
|
||||
LV=LV-1: REM track basic return stack level
|
||||
|
||||
REM release everything we couldn't release earlier
|
||||
GOSUB RELEASE_PEND
|
||||
|
||||
REM trigger GC
|
||||
#cbm TA=FRE(0)
|
||||
#qbasic TA=0
|
||||
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
END SUB
|
||||
|
||||
REM PRINT(A) -> R$
|
||||
MAL_PRINT:
|
||||
AZ=A:PR=1:GOSUB PR_STR
|
||||
RETURN
|
||||
|
||||
REM RE(A$) -> R
|
||||
REM Assume D has repl_env
|
||||
REM caller must release result
|
||||
RE:
|
||||
R1=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO RE_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
|
||||
RE_DONE:
|
||||
REM Release memory from MAL_READ
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
RETURN: REM caller must release result of EVAL
|
||||
|
||||
REM REP(A$) -> R$
|
||||
REM Assume D has repl_env
|
||||
SUB REP
|
||||
R1=0:R2=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
R2=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:GOSUB MAL_PRINT
|
||||
RT$=R$
|
||||
|
||||
REP_DONE:
|
||||
REM Release memory from MAL_READ and EVAL
|
||||
IF R2<>0 THEN AY=R2:GOSUB RELEASE
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
R$=RT$
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
GOSUB INIT_MEMORY
|
||||
|
||||
LV=0
|
||||
|
||||
REM create repl_env
|
||||
O=-1:GOSUB ENV_NEW:D=R
|
||||
|
||||
REM core.EXT: defined in Basic
|
||||
E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
|
||||
|
||||
ZT=ZI: REM top of memory after base repl_env
|
||||
|
||||
REM core.mal: defined using the language itself
|
||||
A$="(def! not (fn* (a) (if a false true)))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(def! load-file (fn* (f) (eval (read-file f))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM load the args file
|
||||
A$="(def! -*ARGS*- (load-file "+CHR$(34)+".args.mal"+CHR$(34)+"))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM set the argument list
|
||||
A$="(def! *ARGV* (rest -*ARGS*-))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM get the first argument
|
||||
A$="(first -*ARGS*-)"
|
||||
GOSUB RE
|
||||
|
||||
REM if there is an argument, then run it as a program
|
||||
IF R<>0 THEN AY=R:GOSUB RELEASE:GOTO RUN_PROG
|
||||
REM no arguments, start REPL loop
|
||||
IF R=0 THEN GOTO REPL_LOOP
|
||||
|
||||
RUN_PROG:
|
||||
REM run a single mal program and exit
|
||||
A$="(load-file (first -*ARGS*-))"
|
||||
GOSUB RE
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR
|
||||
GOTO QUIT
|
||||
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
REM GOSUB PR_MEMORY_SUMMARY
|
||||
END
|
||||
|
||||
PRINT_ERROR:
|
||||
PRINT "Error: "+ER$
|
||||
ER=-2:ER$=""
|
||||
RETURN
|
||||
|
618
basic/step8_macros.in.bas
Executable file
618
basic/step8_macros.in.bas
Executable file
@ -0,0 +1,618 @@
|
||||
REM POKE 1, PEEK(1)AND248: REM enable all ROM areas as RAM
|
||||
REM POKE 55,0: POKE 56,192: CLR: REM move BASIC end from $A000 to $C000
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
REM $INCLUDE: 'types.in.bas'
|
||||
REM $INCLUDE: 'reader.in.bas'
|
||||
REM $INCLUDE: 'printer.in.bas'
|
||||
REM $INCLUDE: 'env.in.bas'
|
||||
REM $INCLUDE: 'core.in.bas'
|
||||
|
||||
REM $INCLUDE: 'debug.in.bas'
|
||||
|
||||
REM READ(A$) -> R
|
||||
MAL_READ:
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
|
||||
REM QUASIQUOTE(A) -> R
|
||||
SUB QUASIQUOTE
|
||||
REM pair?
|
||||
IF (Z%(A,0)AND 31)<6 OR (Z%(A,0)AND 31)>7 THEN GOTO QQ_QUOTE
|
||||
IF (Z%(A,1)=0) THEN GOTO QQ_QUOTE
|
||||
GOTO QQ_UNQUOTE
|
||||
|
||||
QQ_QUOTE:
|
||||
REM ['quote, ast]
|
||||
AS$="quote":T=5:GOSUB STRING
|
||||
B2=R:B1=A:GOSUB LIST2
|
||||
AY=B2:GOSUB RELEASE
|
||||
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_UNQUOTE:
|
||||
R=A+1:GOSUB DEREF_R
|
||||
IF (Z%(R,0)AND 31)<>5 THEN GOTO QQ_SPLICE_UNQUOTE
|
||||
IF S$(Z%(R,1))<>"unquote" THEN GOTO QQ_SPLICE_UNQUOTE
|
||||
REM [ast[1]]
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_SPLICE_UNQUOTE:
|
||||
REM push A on the stack
|
||||
X=X+1:X%(X)=A
|
||||
REM rest of cases call quasiquote on ast[1..]
|
||||
A=Z%(A,1):CALL QUASIQUOTE
|
||||
T6=R
|
||||
REM pop A off the stack
|
||||
A=X%(X):X=X-1
|
||||
|
||||
REM set A to ast[0] for last two cases
|
||||
A=A+1:GOSUB DEREF_A
|
||||
|
||||
REM pair?
|
||||
IF (Z%(A,0)AND 31)<6 OR (Z%(A,0)AND 31)>7 THEN GOTO QQ_DEFAULT
|
||||
IF (Z%(A,1)=0) THEN GOTO QQ_DEFAULT
|
||||
|
||||
B=A+1:GOSUB DEREF_B
|
||||
IF (Z%(B,0)AND 31)<>5 THEN GOTO QQ_DEFAULT
|
||||
IF S$(Z%(B,1))<>"splice-unquote" THEN QQ_DEFAULT
|
||||
REM ['concat, ast[0][1], quasiquote(ast[1..])]
|
||||
|
||||
B=Z%(A,1)+1:GOSUB DEREF_B:B2=B
|
||||
AS$="concat":T=5:GOSUB STRING:B3=R
|
||||
B1=T6:GOSUB LIST3
|
||||
REM release inner quasiquoted since outer list takes ownership
|
||||
AY=B1:GOSUB RELEASE
|
||||
AY=B3:GOSUB RELEASE
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_DEFAULT:
|
||||
REM ['cons, quasiquote(ast[0]), quasiquote(ast[1..])]
|
||||
|
||||
REM push T6 on the stack
|
||||
X=X+1:X%(X)=T6
|
||||
REM A set above to ast[0]
|
||||
CALL QUASIQUOTE
|
||||
B2=R
|
||||
REM pop T6 off the stack
|
||||
T6=X%(X):X=X-1
|
||||
|
||||
AS$="cons":T=5:GOSUB STRING:B3=R
|
||||
B1=T6:GOSUB LIST3
|
||||
REM release inner quasiquoted since outer list takes ownership
|
||||
AY=B1:GOSUB RELEASE
|
||||
AY=B2:GOSUB RELEASE
|
||||
AY=B3:GOSUB RELEASE
|
||||
QQ_DONE:
|
||||
END SUB
|
||||
|
||||
REM MACROEXPAND(A, E) -> A:
|
||||
SUB MACROEXPAND
|
||||
REM push original A
|
||||
X=X+1:X%(X)=A
|
||||
|
||||
MACROEXPAND_LOOP:
|
||||
REM list?
|
||||
IF (Z%(A,0)AND 31)<>6 THEN GOTO MACROEXPAND_DONE
|
||||
REM non-empty?
|
||||
IF Z%(A,1)=0 THEN GOTO MACROEXPAND_DONE
|
||||
B=A+1:GOSUB DEREF_B
|
||||
REM symbol? in first position
|
||||
IF (Z%(B,0)AND 31)<>5 THEN GOTO MACROEXPAND_DONE
|
||||
REM defined in environment?
|
||||
K=B:CALL ENV_FIND
|
||||
IF R=-1 THEN GOTO MACROEXPAND_DONE
|
||||
B=T4:GOSUB DEREF_B
|
||||
REM macro?
|
||||
IF (Z%(B,0)AND 31)<>11 THEN GOTO MACROEXPAND_DONE
|
||||
|
||||
F=B:AR=Z%(A,1):CALL APPLY
|
||||
A=R
|
||||
|
||||
AY=X%(X)
|
||||
REM if previous A was not the first A into macroexpand (i.e. an
|
||||
REM intermediate form) then free it
|
||||
IF A<>AY THEN Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV
|
||||
|
||||
IF ER<>-2 THEN GOTO MACROEXPAND_DONE
|
||||
GOTO MACROEXPAND_LOOP
|
||||
|
||||
MACROEXPAND_DONE:
|
||||
X=X-1: REM pop original A
|
||||
END SUB
|
||||
|
||||
REM EVAL_AST(A, E) -> R
|
||||
SUB EVAL_AST
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_RETURN
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
T=Z%(A,0)AND 31
|
||||
IF T=5 THEN GOTO EVAL_AST_SYMBOL
|
||||
IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ
|
||||
|
||||
REM scalar: deref to actual value and inc ref cnt
|
||||
R=A:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SYMBOL:
|
||||
K=A:GOTO ENV_GET
|
||||
ENV_GET_RETURN:
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SEQ:
|
||||
REM allocate the first entry (T already set above)
|
||||
L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM make space on the stack
|
||||
X=X+4
|
||||
REM push type of sequence
|
||||
X%(X-3)=T
|
||||
REM push sequence index
|
||||
X%(X-2)=-1
|
||||
REM push future return value (new sequence)
|
||||
X%(X-1)=R
|
||||
REM push previous new sequence entry
|
||||
X%(X)=R
|
||||
|
||||
EVAL_AST_SEQ_LOOP:
|
||||
REM update index
|
||||
X%(X-2)=X%(X-2)+1
|
||||
|
||||
REM check if we are done evaluating the source sequence
|
||||
IF Z%(A,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if we are returning to DO, then skip last element
|
||||
IF X%(X-6)=2 AND Z%(Z%(A,1),1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if hashmap, skip eval of even entries (keys)
|
||||
IF (X%(X-3)=8) AND ((X%(X-2)AND 1)=0) THEN GOTO EVAL_AST_DO_REF
|
||||
GOTO EVAL_AST_DO_EVAL
|
||||
|
||||
EVAL_AST_DO_REF:
|
||||
R=A+1:GOSUB DEREF_R: REM deref to target of referred entry
|
||||
Z%(R,0)=Z%(R,0)+32: REM inc ref cnt of referred value
|
||||
GOTO EVAL_AST_ADD_VALUE
|
||||
|
||||
EVAL_AST_DO_EVAL:
|
||||
REM call EVAL for each entry
|
||||
A=A+1:CALL EVAL
|
||||
A=A-1
|
||||
GOSUB DEREF_R: REM deref to target of evaluated entry
|
||||
|
||||
EVAL_AST_ADD_VALUE:
|
||||
|
||||
REM update previous value pointer to evaluated entry
|
||||
Z%(X%(X)+1,1)=R
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM allocate the next entry
|
||||
REM same new sequence entry type
|
||||
T=X%(X-3):L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM update previous sequence entry value to point to new entry
|
||||
Z%(X%(X),1)=R
|
||||
REM update previous ptr to current entry
|
||||
X%(X)=R
|
||||
|
||||
REM process the next sequence entry from source list
|
||||
A=Z%(A,1)
|
||||
|
||||
GOTO EVAL_AST_SEQ_LOOP
|
||||
EVAL_AST_SEQ_LOOP_DONE:
|
||||
REM if no error, get return value (new seq)
|
||||
IF ER=-2 THEN R=X%(X-1)
|
||||
REM otherwise, free the return value and return nil
|
||||
IF ER<>-2 THEN R=0:AY=X%(X-1):GOSUB RELEASE
|
||||
|
||||
REM pop previous, return, index and type
|
||||
X=X-4
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_RETURN:
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
END SUB
|
||||
|
||||
REM EVAL(A, E) -> R
|
||||
SUB EVAL
|
||||
LV=LV+1: REM track basic return stack level
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0))
|
||||
|
||||
EVAL_TCO_RECUR:
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM AZ=A:PR=1:GOSUB PR_STR
|
||||
REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R THEN GOTO APPLY_LIST
|
||||
EVAL_NOT_LIST:
|
||||
REM ELSE
|
||||
CALL EVAL_AST
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
APPLY_LIST:
|
||||
CALL MACROEXPAND
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R<>1 THEN GOTO EVAL_NOT_LIST
|
||||
|
||||
GOSUB EMPTY_Q
|
||||
IF R THEN R=A:Z%(R,0)=Z%(R,0)+32:GOTO EVAL_RETURN
|
||||
|
||||
A0=A+1
|
||||
R=A0:GOSUB DEREF_R:A0=R
|
||||
|
||||
REM get symbol in A$
|
||||
IF (Z%(A0,0)AND 31)<>5 THEN A$=""
|
||||
IF (Z%(A0,0)AND 31)=5 THEN A$=S$(Z%(A0,1))
|
||||
|
||||
IF A$="def!" THEN GOTO EVAL_DEF
|
||||
IF A$="let*" THEN GOTO EVAL_LET
|
||||
IF A$="quote" THEN GOTO EVAL_QUOTE
|
||||
IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE
|
||||
IF A$="defmacro!" THEN GOTO EVAL_DEFMACRO
|
||||
IF A$="macroexpand" THEN GOTO EVAL_MACROEXPAND
|
||||
IF A$="do" THEN GOTO EVAL_DO
|
||||
IF A$="if" THEN GOTO EVAL_IF
|
||||
IF A$="fn*" THEN GOTO EVAL_FN
|
||||
GOTO EVAL_INVOKE
|
||||
|
||||
EVAL_GET_A3:
|
||||
A3=Z%(Z%(Z%(A,1),1),1)+1
|
||||
R=A3:GOSUB DEREF_R:A3=R
|
||||
EVAL_GET_A2:
|
||||
A2=Z%(Z%(A,1),1)+1
|
||||
R=A2:GOSUB DEREF_R:A2=R
|
||||
EVAL_GET_A1:
|
||||
A1=Z%(A,1)+1
|
||||
R=A1:GOSUB DEREF_R:A1=R
|
||||
RETURN
|
||||
|
||||
EVAL_DEF:
|
||||
REM PRINT "def!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval a2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM set a1 in env to a2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_LET:
|
||||
REM PRINT "let*"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A2: REM push/save A2
|
||||
X=X+1:X%(X)=E: REM push env for for later release
|
||||
|
||||
REM create new environment with outer as current environment
|
||||
O=E:GOSUB ENV_NEW
|
||||
E=R
|
||||
EVAL_LET_LOOP:
|
||||
IF Z%(A1,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
REM eval current A1 odd element
|
||||
A=Z%(A1,1)+1:CALL EVAL
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
REM set environment: even A1 key to odd A1 eval'd above
|
||||
K=A1+1:V=R:GOSUB ENV_SET
|
||||
AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership
|
||||
|
||||
REM skip to the next pair of A1 elements
|
||||
A1=Z%(Z%(A1,1),1)
|
||||
GOTO EVAL_LET_LOOP
|
||||
|
||||
EVAL_LET_LOOP_DONE:
|
||||
E4=X%(X):X=X-1: REM pop previous env
|
||||
|
||||
REM release previous environment if not the current EVAL env
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
A2=X%(X):X=X-1: REM pop A2
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_DO:
|
||||
A=Z%(A,1): REM rest
|
||||
X=X+1:X%(X)=A: REM push/save A
|
||||
|
||||
CALL EVAL_AST
|
||||
|
||||
REM cleanup
|
||||
AY=R: REM get eval'd list for release
|
||||
|
||||
A=X%(X):X=X-1: REM pop/restore original A for LAST
|
||||
GOSUB LAST: REM get last element for return
|
||||
A=R: REM new recur AST
|
||||
|
||||
REM cleanup
|
||||
GOSUB RELEASE: REM release eval'd list
|
||||
AY=A:GOSUB RELEASE: REM release LAST value (not sure why)
|
||||
|
||||
GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_QUOTE:
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_QUASIQUOTE:
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
A=R:CALL QUASIQUOTE
|
||||
REM add quasiquote result to pending release queue to free when
|
||||
REM next lower EVAL level returns (LV)
|
||||
Y=Y+1:Y%(Y,0)=R:Y%(Y,1)=LV
|
||||
|
||||
A=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_DEFMACRO:
|
||||
REM PRINT "defmacro!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval A2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
REM change function to macro
|
||||
Z%(R,0)=Z%(R,0)+1
|
||||
|
||||
REM set A1 in env to A2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_MACROEXPAND:
|
||||
REM PRINT "macroexpand"
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
A=R:CALL MACROEXPAND
|
||||
R=A
|
||||
|
||||
REM since we are returning it unevaluated, inc the ref cnt
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_IF:
|
||||
GOSUB EVAL_GET_A1: REM set A1
|
||||
REM push A
|
||||
X=X+1:X%(X)=A
|
||||
A=A1:CALL EVAL
|
||||
REM pop A
|
||||
A=X%(X):X=X-1
|
||||
IF (R=0) OR (R=1) THEN GOTO EVAL_IF_FALSE
|
||||
|
||||
EVAL_IF_TRUE:
|
||||
AY=R:GOSUB RELEASE
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
EVAL_IF_FALSE:
|
||||
AY=R:GOSUB RELEASE
|
||||
REM if no false case (A3), return nil
|
||||
B=A:GOSUB COUNT
|
||||
IF R<4 THEN R=0:GOTO EVAL_RETURN
|
||||
GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL
|
||||
A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_FN:
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
A=A2:P=A1:GOSUB MAL_FUNCTION
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_INVOKE:
|
||||
CALL EVAL_AST
|
||||
|
||||
REM if error, return f/args for release by caller
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM push f/args for release after call
|
||||
X=X+1:X%(X)=R
|
||||
|
||||
F=R+1
|
||||
|
||||
AR=Z%(R,1): REM rest
|
||||
R=F:GOSUB DEREF_R:F=R
|
||||
|
||||
REM if metadata, get the actual object
|
||||
IF (Z%(F,0)AND 31)>=16 THEN F=Z%(F,1)
|
||||
|
||||
IF (Z%(F,0)AND 31)=9 THEN GOTO EVAL_DO_FUNCTION
|
||||
IF (Z%(F,0)AND 31)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
|
||||
|
||||
REM if error, pop and return f/args for release by caller
|
||||
R=X%(X):X=X-1
|
||||
ER=-1:ER$="apply of non-function":GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_FUNCTION:
|
||||
REM regular function
|
||||
IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
|
||||
REM for recur functions (apply, map, swap!), use GOTO
|
||||
IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
|
||||
EVAL_DO_FUNCTION_SKIP:
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_MAL_FUNCTION:
|
||||
E4=E: REM save the current environment for release
|
||||
|
||||
REM create new environ using env stored with function
|
||||
O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
|
||||
|
||||
REM release previous env if it is not the top one on the
|
||||
REM stack (X%(X-2)) because our new env refers to it and
|
||||
REM we no longer need to track it (since we are TCO recurring)
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
REM claim the AST before releasing the list containing it
|
||||
A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
|
||||
REM add AST to pending release queue to free as soon as EVAL
|
||||
REM actually returns (LV+1)
|
||||
Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV+1
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
|
||||
REM A set above
|
||||
E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_RETURN:
|
||||
REM AZ=R: PR=1: GOSUB PR_STR
|
||||
REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER)
|
||||
|
||||
REM release environment if not the top one on the stack
|
||||
IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
|
||||
|
||||
LV=LV-1: REM track basic return stack level
|
||||
|
||||
REM release everything we couldn't release earlier
|
||||
GOSUB RELEASE_PEND
|
||||
|
||||
REM trigger GC
|
||||
#cbm TA=FRE(0)
|
||||
#qbasic TA=0
|
||||
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
END SUB
|
||||
|
||||
REM PRINT(A) -> R$
|
||||
MAL_PRINT:
|
||||
AZ=A:PR=1:GOSUB PR_STR
|
||||
RETURN
|
||||
|
||||
REM RE(A$) -> R
|
||||
REM Assume D has repl_env
|
||||
REM caller must release result
|
||||
RE:
|
||||
R1=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO RE_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
|
||||
RE_DONE:
|
||||
REM Release memory from MAL_READ
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
RETURN: REM caller must release result of EVAL
|
||||
|
||||
REM REP(A$) -> R$
|
||||
REM Assume D has repl_env
|
||||
SUB REP
|
||||
R1=0:R2=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
R2=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:GOSUB MAL_PRINT
|
||||
RT$=R$
|
||||
|
||||
REP_DONE:
|
||||
REM Release memory from MAL_READ and EVAL
|
||||
IF R2<>0 THEN AY=R2:GOSUB RELEASE
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
R$=RT$
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
GOSUB INIT_MEMORY
|
||||
|
||||
LV=0
|
||||
|
||||
REM create repl_env
|
||||
O=-1:GOSUB ENV_NEW:D=R
|
||||
|
||||
REM core.EXT: defined in Basic
|
||||
E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
|
||||
|
||||
ZT=ZI: REM top of memory after base repl_env
|
||||
|
||||
REM core.mal: defined using the language itself
|
||||
A$="(def! not (fn* (a) (if a false true)))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(def! load-file (fn* (f) (eval (read-file f))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)"
|
||||
A$=A$+" (if (> (count xs) 1) (nth xs 1) (throw "+CHR$(34)+"odd number of"
|
||||
A$=A$+" forms to cond"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs)"
|
||||
A$=A$+" `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM load the args file
|
||||
A$="(def! -*ARGS*- (load-file "+CHR$(34)+".args.mal"+CHR$(34)+"))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM set the argument list
|
||||
A$="(def! *ARGV* (rest -*ARGS*-))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM get the first argument
|
||||
A$="(first -*ARGS*-)"
|
||||
GOSUB RE
|
||||
|
||||
REM if there is an argument, then run it as a program
|
||||
IF R<>0 THEN AY=R:GOSUB RELEASE:GOTO RUN_PROG
|
||||
REM no arguments, start REPL loop
|
||||
IF R=0 THEN GOTO REPL_LOOP
|
||||
|
||||
RUN_PROG:
|
||||
REM run a single mal program and exit
|
||||
A$="(load-file (first -*ARGS*-))"
|
||||
GOSUB RE
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR
|
||||
GOTO QUIT
|
||||
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
REM GOSUB PR_MEMORY_SUMMARY
|
||||
END
|
||||
|
||||
PRINT_ERROR:
|
||||
PRINT "Error: "+ER$
|
||||
ER=-2:ER$=""
|
||||
RETURN
|
||||
|
652
basic/step9_try.in.bas
Executable file
652
basic/step9_try.in.bas
Executable file
@ -0,0 +1,652 @@
|
||||
REM POKE 1, PEEK(1)AND248: REM enable all ROM areas as RAM
|
||||
REM POKE 55,0: POKE 56,192: CLR: REM move BASIC end from $A000 to $C000
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
REM $INCLUDE: 'types.in.bas'
|
||||
REM $INCLUDE: 'reader.in.bas'
|
||||
REM $INCLUDE: 'printer.in.bas'
|
||||
REM $INCLUDE: 'env.in.bas'
|
||||
REM $INCLUDE: 'core.in.bas'
|
||||
|
||||
REM $INCLUDE: 'debug.in.bas'
|
||||
|
||||
REM READ(A$) -> R
|
||||
MAL_READ:
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
|
||||
REM QUASIQUOTE(A) -> R
|
||||
SUB QUASIQUOTE
|
||||
REM pair?
|
||||
IF (Z%(A,0)AND 31)<6 OR (Z%(A,0)AND 31)>7 THEN GOTO QQ_QUOTE
|
||||
IF (Z%(A,1)=0) THEN GOTO QQ_QUOTE
|
||||
GOTO QQ_UNQUOTE
|
||||
|
||||
QQ_QUOTE:
|
||||
REM ['quote, ast]
|
||||
AS$="quote":T=5:GOSUB STRING
|
||||
B2=R:B1=A:GOSUB LIST2
|
||||
AY=B2:GOSUB RELEASE
|
||||
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_UNQUOTE:
|
||||
R=A+1:GOSUB DEREF_R
|
||||
IF (Z%(R,0)AND 31)<>5 THEN GOTO QQ_SPLICE_UNQUOTE
|
||||
IF S$(Z%(R,1))<>"unquote" THEN GOTO QQ_SPLICE_UNQUOTE
|
||||
REM [ast[1]]
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_SPLICE_UNQUOTE:
|
||||
REM push A on the stack
|
||||
X=X+1:X%(X)=A
|
||||
REM rest of cases call quasiquote on ast[1..]
|
||||
A=Z%(A,1):CALL QUASIQUOTE
|
||||
T6=R
|
||||
REM pop A off the stack
|
||||
A=X%(X):X=X-1
|
||||
|
||||
REM set A to ast[0] for last two cases
|
||||
A=A+1:GOSUB DEREF_A
|
||||
|
||||
REM pair?
|
||||
IF (Z%(A,0)AND 31)<6 OR (Z%(A,0)AND 31)>7 THEN GOTO QQ_DEFAULT
|
||||
IF (Z%(A,1)=0) THEN GOTO QQ_DEFAULT
|
||||
|
||||
B=A+1:GOSUB DEREF_B
|
||||
IF (Z%(B,0)AND 31)<>5 THEN GOTO QQ_DEFAULT
|
||||
IF S$(Z%(B,1))<>"splice-unquote" THEN QQ_DEFAULT
|
||||
REM ['concat, ast[0][1], quasiquote(ast[1..])]
|
||||
|
||||
B=Z%(A,1)+1:GOSUB DEREF_B:B2=B
|
||||
AS$="concat":T=5:GOSUB STRING:B3=R
|
||||
B1=T6:GOSUB LIST3
|
||||
REM release inner quasiquoted since outer list takes ownership
|
||||
AY=B1:GOSUB RELEASE
|
||||
AY=B3:GOSUB RELEASE
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_DEFAULT:
|
||||
REM ['cons, quasiquote(ast[0]), quasiquote(ast[1..])]
|
||||
|
||||
REM push T6 on the stack
|
||||
X=X+1:X%(X)=T6
|
||||
REM A set above to ast[0]
|
||||
CALL QUASIQUOTE
|
||||
B2=R
|
||||
REM pop T6 off the stack
|
||||
T6=X%(X):X=X-1
|
||||
|
||||
AS$="cons":T=5:GOSUB STRING:B3=R
|
||||
B1=T6:GOSUB LIST3
|
||||
REM release inner quasiquoted since outer list takes ownership
|
||||
AY=B1:GOSUB RELEASE
|
||||
AY=B2:GOSUB RELEASE
|
||||
AY=B3:GOSUB RELEASE
|
||||
QQ_DONE:
|
||||
END SUB
|
||||
|
||||
REM MACROEXPAND(A, E) -> A:
|
||||
SUB MACROEXPAND
|
||||
REM push original A
|
||||
X=X+1:X%(X)=A
|
||||
|
||||
MACROEXPAND_LOOP:
|
||||
REM list?
|
||||
IF (Z%(A,0)AND 31)<>6 THEN GOTO MACROEXPAND_DONE
|
||||
REM non-empty?
|
||||
IF Z%(A,1)=0 THEN GOTO MACROEXPAND_DONE
|
||||
B=A+1:GOSUB DEREF_B
|
||||
REM symbol? in first position
|
||||
IF (Z%(B,0)AND 31)<>5 THEN GOTO MACROEXPAND_DONE
|
||||
REM defined in environment?
|
||||
K=B:CALL ENV_FIND
|
||||
IF R=-1 THEN GOTO MACROEXPAND_DONE
|
||||
B=T4:GOSUB DEREF_B
|
||||
REM macro?
|
||||
IF (Z%(B,0)AND 31)<>11 THEN GOTO MACROEXPAND_DONE
|
||||
|
||||
F=B:AR=Z%(A,1):CALL APPLY
|
||||
A=R
|
||||
|
||||
AY=X%(X)
|
||||
REM if previous A was not the first A into macroexpand (i.e. an
|
||||
REM intermediate form) then free it
|
||||
IF A<>AY THEN Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV
|
||||
|
||||
IF ER<>-2 THEN GOTO MACROEXPAND_DONE
|
||||
GOTO MACROEXPAND_LOOP
|
||||
|
||||
MACROEXPAND_DONE:
|
||||
X=X-1: REM pop original A
|
||||
END SUB
|
||||
|
||||
REM EVAL_AST(A, E) -> R
|
||||
SUB EVAL_AST
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_RETURN
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
T=Z%(A,0)AND 31
|
||||
IF T=5 THEN GOTO EVAL_AST_SYMBOL
|
||||
IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ
|
||||
|
||||
REM scalar: deref to actual value and inc ref cnt
|
||||
R=A:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SYMBOL:
|
||||
K=A:GOTO ENV_GET
|
||||
ENV_GET_RETURN:
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SEQ:
|
||||
REM allocate the first entry (T already set above)
|
||||
L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM make space on the stack
|
||||
X=X+4
|
||||
REM push type of sequence
|
||||
X%(X-3)=T
|
||||
REM push sequence index
|
||||
X%(X-2)=-1
|
||||
REM push future return value (new sequence)
|
||||
X%(X-1)=R
|
||||
REM push previous new sequence entry
|
||||
X%(X)=R
|
||||
|
||||
EVAL_AST_SEQ_LOOP:
|
||||
REM update index
|
||||
X%(X-2)=X%(X-2)+1
|
||||
|
||||
REM check if we are done evaluating the source sequence
|
||||
IF Z%(A,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if we are returning to DO, then skip last element
|
||||
IF X%(X-6)=2 AND Z%(Z%(A,1),1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if hashmap, skip eval of even entries (keys)
|
||||
IF (X%(X-3)=8) AND ((X%(X-2)AND 1)=0) THEN GOTO EVAL_AST_DO_REF
|
||||
GOTO EVAL_AST_DO_EVAL
|
||||
|
||||
EVAL_AST_DO_REF:
|
||||
R=A+1:GOSUB DEREF_R: REM deref to target of referred entry
|
||||
Z%(R,0)=Z%(R,0)+32: REM inc ref cnt of referred value
|
||||
GOTO EVAL_AST_ADD_VALUE
|
||||
|
||||
EVAL_AST_DO_EVAL:
|
||||
REM call EVAL for each entry
|
||||
A=A+1:CALL EVAL
|
||||
A=A-1
|
||||
GOSUB DEREF_R: REM deref to target of evaluated entry
|
||||
|
||||
EVAL_AST_ADD_VALUE:
|
||||
|
||||
REM update previous value pointer to evaluated entry
|
||||
Z%(X%(X)+1,1)=R
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM allocate the next entry
|
||||
REM same new sequence entry type
|
||||
T=X%(X-3):L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM update previous sequence entry value to point to new entry
|
||||
Z%(X%(X),1)=R
|
||||
REM update previous ptr to current entry
|
||||
X%(X)=R
|
||||
|
||||
REM process the next sequence entry from source list
|
||||
A=Z%(A,1)
|
||||
|
||||
GOTO EVAL_AST_SEQ_LOOP
|
||||
EVAL_AST_SEQ_LOOP_DONE:
|
||||
REM if no error, get return value (new seq)
|
||||
IF ER=-2 THEN R=X%(X-1)
|
||||
REM otherwise, free the return value and return nil
|
||||
IF ER<>-2 THEN R=0:AY=X%(X-1):GOSUB RELEASE
|
||||
|
||||
REM pop previous, return, index and type
|
||||
X=X-4
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_RETURN:
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
END SUB
|
||||
|
||||
REM EVAL(A, E) -> R
|
||||
SUB EVAL
|
||||
LV=LV+1: REM track basic return stack level
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0))
|
||||
|
||||
EVAL_TCO_RECUR:
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM AZ=A:PR=1:GOSUB PR_STR
|
||||
REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R THEN GOTO APPLY_LIST
|
||||
EVAL_NOT_LIST:
|
||||
REM ELSE
|
||||
CALL EVAL_AST
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
APPLY_LIST:
|
||||
CALL MACROEXPAND
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R<>1 THEN GOTO EVAL_NOT_LIST
|
||||
|
||||
GOSUB EMPTY_Q
|
||||
IF R THEN R=A:Z%(R,0)=Z%(R,0)+32:GOTO EVAL_RETURN
|
||||
|
||||
A0=A+1
|
||||
R=A0:GOSUB DEREF_R:A0=R
|
||||
|
||||
REM get symbol in A$
|
||||
IF (Z%(A0,0)AND 31)<>5 THEN A$=""
|
||||
IF (Z%(A0,0)AND 31)=5 THEN A$=S$(Z%(A0,1))
|
||||
|
||||
IF A$="def!" THEN GOTO EVAL_DEF
|
||||
IF A$="let*" THEN GOTO EVAL_LET
|
||||
IF A$="quote" THEN GOTO EVAL_QUOTE
|
||||
IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE
|
||||
IF A$="defmacro!" THEN GOTO EVAL_DEFMACRO
|
||||
IF A$="macroexpand" THEN GOTO EVAL_MACROEXPAND
|
||||
IF A$="try*" THEN GOTO EVAL_TRY
|
||||
IF A$="do" THEN GOTO EVAL_DO
|
||||
IF A$="if" THEN GOTO EVAL_IF
|
||||
IF A$="fn*" THEN GOTO EVAL_FN
|
||||
GOTO EVAL_INVOKE
|
||||
|
||||
EVAL_GET_A3:
|
||||
A3=Z%(Z%(Z%(A,1),1),1)+1
|
||||
R=A3:GOSUB DEREF_R:A3=R
|
||||
EVAL_GET_A2:
|
||||
A2=Z%(Z%(A,1),1)+1
|
||||
R=A2:GOSUB DEREF_R:A2=R
|
||||
EVAL_GET_A1:
|
||||
A1=Z%(A,1)+1
|
||||
R=A1:GOSUB DEREF_R:A1=R
|
||||
RETURN
|
||||
|
||||
EVAL_DEF:
|
||||
REM PRINT "def!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval a2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM set a1 in env to a2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_LET:
|
||||
REM PRINT "let*"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A2: REM push/save A2
|
||||
X=X+1:X%(X)=E: REM push env for for later release
|
||||
|
||||
REM create new environment with outer as current environment
|
||||
O=E:GOSUB ENV_NEW
|
||||
E=R
|
||||
EVAL_LET_LOOP:
|
||||
IF Z%(A1,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
REM eval current A1 odd element
|
||||
A=Z%(A1,1)+1:CALL EVAL
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
REM set environment: even A1 key to odd A1 eval'd above
|
||||
K=A1+1:V=R:GOSUB ENV_SET
|
||||
AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership
|
||||
|
||||
REM skip to the next pair of A1 elements
|
||||
A1=Z%(Z%(A1,1),1)
|
||||
GOTO EVAL_LET_LOOP
|
||||
|
||||
EVAL_LET_LOOP_DONE:
|
||||
E4=X%(X):X=X-1: REM pop previous env
|
||||
|
||||
REM release previous environment if not the current EVAL env
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
A2=X%(X):X=X-1: REM pop A2
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_DO:
|
||||
A=Z%(A,1): REM rest
|
||||
X=X+1:X%(X)=A: REM push/save A
|
||||
|
||||
CALL EVAL_AST
|
||||
|
||||
REM cleanup
|
||||
AY=R: REM get eval'd list for release
|
||||
|
||||
A=X%(X):X=X-1: REM pop/restore original A for LAST
|
||||
GOSUB LAST: REM get last element for return
|
||||
A=R: REM new recur AST
|
||||
|
||||
REM cleanup
|
||||
GOSUB RELEASE: REM release eval'd list
|
||||
AY=A:GOSUB RELEASE: REM release LAST value (not sure why)
|
||||
|
||||
GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_QUOTE:
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_QUASIQUOTE:
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
A=R:CALL QUASIQUOTE
|
||||
REM add quasiquote result to pending release queue to free when
|
||||
REM next lower EVAL level returns (LV)
|
||||
Y=Y+1:Y%(Y,0)=R:Y%(Y,1)=LV
|
||||
|
||||
A=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_DEFMACRO:
|
||||
REM PRINT "defmacro!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval A2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
REM change function to macro
|
||||
Z%(R,0)=Z%(R,0)+1
|
||||
|
||||
REM set A1 in env to A2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_MACROEXPAND:
|
||||
REM PRINT "macroexpand"
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
A=R:CALL MACROEXPAND
|
||||
R=A
|
||||
|
||||
REM since we are returning it unevaluated, inc the ref cnt
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_TRY:
|
||||
REM PRINT "try*"
|
||||
GOSUB EVAL_GET_A1: REM set A1, A2, and A3
|
||||
|
||||
X=X+1:X%(X)=A: REM push/save A
|
||||
A=A1:CALL EVAL: REM eval A1
|
||||
A=X%(X):X=X-1: REM pop/restore A
|
||||
|
||||
REM if there is not error or catch block then return
|
||||
IF ER=-2 OR Z%(A,1)=0 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM create environment for the catch block eval
|
||||
O=E:GOSUB ENV_NEW:E=R
|
||||
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
A=A2:GOSUB EVAL_GET_A2: REM set A1 and A2 from catch block
|
||||
|
||||
REM create object for ER=-1 type raw string errors
|
||||
IF ER=-1 THEN AS$=ER$:T=4:GOSUB STRING:ER=R:Z%(R,0)=Z%(R,0)+32
|
||||
|
||||
REM bind the catch symbol to the error object
|
||||
K=A1:V=ER:GOSUB ENV_SET
|
||||
AY=R:GOSUB RELEASE: REM release our use, env took ownership
|
||||
|
||||
REM unset error for catch eval
|
||||
ER=-2:ER$=""
|
||||
|
||||
A=A2:CALL EVAL
|
||||
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_IF:
|
||||
GOSUB EVAL_GET_A1: REM set A1
|
||||
REM push A
|
||||
X=X+1:X%(X)=A
|
||||
A=A1:CALL EVAL
|
||||
REM pop A
|
||||
A=X%(X):X=X-1
|
||||
IF (R=0) OR (R=1) THEN GOTO EVAL_IF_FALSE
|
||||
|
||||
EVAL_IF_TRUE:
|
||||
AY=R:GOSUB RELEASE
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
EVAL_IF_FALSE:
|
||||
AY=R:GOSUB RELEASE
|
||||
REM if no false case (A3), return nil
|
||||
B=A:GOSUB COUNT
|
||||
IF R<4 THEN R=0:GOTO EVAL_RETURN
|
||||
GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL
|
||||
A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_FN:
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
A=A2:P=A1:GOSUB MAL_FUNCTION
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_INVOKE:
|
||||
CALL EVAL_AST
|
||||
|
||||
REM if error, return f/args for release by caller
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM push f/args for release after call
|
||||
X=X+1:X%(X)=R
|
||||
|
||||
F=R+1
|
||||
|
||||
AR=Z%(R,1): REM rest
|
||||
R=F:GOSUB DEREF_R:F=R
|
||||
|
||||
REM if metadata, get the actual object
|
||||
IF (Z%(F,0)AND 31)>=16 THEN F=Z%(F,1)
|
||||
|
||||
IF (Z%(F,0)AND 31)=9 THEN GOTO EVAL_DO_FUNCTION
|
||||
IF (Z%(F,0)AND 31)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
|
||||
|
||||
REM if error, pop and return f/args for release by caller
|
||||
R=X%(X):X=X-1
|
||||
ER=-1:ER$="apply of non-function":GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_FUNCTION:
|
||||
REM regular function
|
||||
IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
|
||||
REM for recur functions (apply, map, swap!), use GOTO
|
||||
IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
|
||||
EVAL_DO_FUNCTION_SKIP:
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_MAL_FUNCTION:
|
||||
E4=E: REM save the current environment for release
|
||||
|
||||
REM create new environ using env stored with function
|
||||
O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
|
||||
|
||||
REM release previous env if it is not the top one on the
|
||||
REM stack (X%(X-2)) because our new env refers to it and
|
||||
REM we no longer need to track it (since we are TCO recurring)
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
REM claim the AST before releasing the list containing it
|
||||
A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
|
||||
REM add AST to pending release queue to free as soon as EVAL
|
||||
REM actually returns (LV+1)
|
||||
Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV+1
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
|
||||
REM A set above
|
||||
E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_RETURN:
|
||||
REM AZ=R: PR=1: GOSUB PR_STR
|
||||
REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER)
|
||||
|
||||
REM release environment if not the top one on the stack
|
||||
IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
|
||||
|
||||
LV=LV-1: REM track basic return stack level
|
||||
|
||||
REM release everything we couldn't release earlier
|
||||
GOSUB RELEASE_PEND
|
||||
|
||||
REM trigger GC
|
||||
#cbm TA=FRE(0)
|
||||
#qbasic TA=0
|
||||
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
END SUB
|
||||
|
||||
REM PRINT(A) -> R$
|
||||
MAL_PRINT:
|
||||
AZ=A:PR=1:GOSUB PR_STR
|
||||
RETURN
|
||||
|
||||
REM RE(A$) -> R
|
||||
REM Assume D has repl_env
|
||||
REM caller must release result
|
||||
RE:
|
||||
R1=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO RE_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
|
||||
RE_DONE:
|
||||
REM Release memory from MAL_READ
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
RETURN: REM caller must release result of EVAL
|
||||
|
||||
REM REP(A$) -> R$
|
||||
REM Assume D has repl_env
|
||||
SUB REP
|
||||
R1=0:R2=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
R2=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:GOSUB MAL_PRINT
|
||||
RT$=R$
|
||||
|
||||
REP_DONE:
|
||||
REM Release memory from MAL_READ and EVAL
|
||||
IF R2<>0 THEN AY=R2:GOSUB RELEASE
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
R$=RT$
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
GOSUB INIT_MEMORY
|
||||
|
||||
LV=0
|
||||
|
||||
REM create repl_env
|
||||
O=-1:GOSUB ENV_NEW:D=R
|
||||
|
||||
REM core.EXT: defined in Basic
|
||||
E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
|
||||
|
||||
ZT=ZI: REM top of memory after base repl_env
|
||||
|
||||
REM core.mal: defined using the language itself
|
||||
A$="(def! not (fn* (a) (if a false true)))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(def! load-file (fn* (f) (eval (read-file f))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)"
|
||||
A$=A$+" (if (> (count xs) 1) (nth xs 1) (throw "+CHR$(34)+"odd number of"
|
||||
A$=A$+" forms to cond"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs)"
|
||||
A$=A$+" `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM load the args file
|
||||
A$="(def! -*ARGS*- (load-file "+CHR$(34)+".args.mal"+CHR$(34)+"))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM set the argument list
|
||||
A$="(def! *ARGV* (rest -*ARGS*-))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM get the first argument
|
||||
A$="(first -*ARGS*-)"
|
||||
GOSUB RE
|
||||
|
||||
REM if there is an argument, then run it as a program
|
||||
IF R<>0 THEN AY=R:GOSUB RELEASE:GOTO RUN_PROG
|
||||
REM no arguments, start REPL loop
|
||||
IF R=0 THEN GOTO REPL_LOOP
|
||||
|
||||
RUN_PROG:
|
||||
REM run a single mal program and exit
|
||||
A$="(load-file (first -*ARGS*-))"
|
||||
GOSUB RE
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR
|
||||
GOTO QUIT
|
||||
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
REM GOSUB PR_MEMORY_SUMMARY
|
||||
END
|
||||
|
||||
PRINT_ERROR:
|
||||
REM if the error is an object, then print and free it
|
||||
IF ER>=0 THEN AZ=ER:PR=0:GOSUB PR_STR:ER$=R$:AY=ER:GOSUB RELEASE
|
||||
PRINT "Error: "+ER$
|
||||
ER=-2:ER$=""
|
||||
RETURN
|
||||
|
670
basic/stepA_mal.in.bas
Executable file
670
basic/stepA_mal.in.bas
Executable file
@ -0,0 +1,670 @@
|
||||
REM POKE 1, PEEK(1)AND248: REM enable all ROM areas as RAM
|
||||
REM POKE 55,0: POKE 56,192: CLR: REM move BASIC end from $A000 to $C000
|
||||
GOTO MAIN
|
||||
|
||||
REM $INCLUDE: 'readline.in.bas'
|
||||
REM $INCLUDE: 'types.in.bas'
|
||||
REM $INCLUDE: 'reader.in.bas'
|
||||
REM $INCLUDE: 'printer.in.bas'
|
||||
REM $INCLUDE: 'env.in.bas'
|
||||
REM $INCLUDE: 'core.in.bas'
|
||||
|
||||
REM $INCLUDE: 'debug.in.bas'
|
||||
|
||||
REM READ(A$) -> R
|
||||
MAL_READ:
|
||||
GOSUB READ_STR
|
||||
RETURN
|
||||
|
||||
REM QUASIQUOTE(A) -> R
|
||||
SUB QUASIQUOTE
|
||||
REM pair?
|
||||
IF (Z%(A,0)AND 31)<6 OR (Z%(A,0)AND 31)>7 THEN GOTO QQ_QUOTE
|
||||
IF (Z%(A,1)=0) THEN GOTO QQ_QUOTE
|
||||
GOTO QQ_UNQUOTE
|
||||
|
||||
QQ_QUOTE:
|
||||
REM ['quote, ast]
|
||||
AS$="quote":T=5:GOSUB STRING
|
||||
B2=R:B1=A:GOSUB LIST2
|
||||
AY=B2:GOSUB RELEASE
|
||||
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_UNQUOTE:
|
||||
R=A+1:GOSUB DEREF_R
|
||||
IF (Z%(R,0)AND 31)<>5 THEN GOTO QQ_SPLICE_UNQUOTE
|
||||
IF S$(Z%(R,1))<>"unquote" THEN GOTO QQ_SPLICE_UNQUOTE
|
||||
REM [ast[1]]
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_SPLICE_UNQUOTE:
|
||||
REM push A on the stack
|
||||
X=X+1:X%(X)=A
|
||||
REM rest of cases call quasiquote on ast[1..]
|
||||
A=Z%(A,1):CALL QUASIQUOTE
|
||||
T6=R
|
||||
REM pop A off the stack
|
||||
A=X%(X):X=X-1
|
||||
|
||||
REM set A to ast[0] for last two cases
|
||||
A=A+1:GOSUB DEREF_A
|
||||
|
||||
REM pair?
|
||||
IF (Z%(A,0)AND 31)<6 OR (Z%(A,0)AND 31)>7 THEN GOTO QQ_DEFAULT
|
||||
IF (Z%(A,1)=0) THEN GOTO QQ_DEFAULT
|
||||
|
||||
B=A+1:GOSUB DEREF_B
|
||||
IF (Z%(B,0)AND 31)<>5 THEN GOTO QQ_DEFAULT
|
||||
IF S$(Z%(B,1))<>"splice-unquote" THEN QQ_DEFAULT
|
||||
REM ['concat, ast[0][1], quasiquote(ast[1..])]
|
||||
|
||||
B=Z%(A,1)+1:GOSUB DEREF_B:B2=B
|
||||
AS$="concat":T=5:GOSUB STRING:B3=R
|
||||
B1=T6:GOSUB LIST3
|
||||
REM release inner quasiquoted since outer list takes ownership
|
||||
AY=B1:GOSUB RELEASE
|
||||
AY=B3:GOSUB RELEASE
|
||||
GOTO QQ_DONE
|
||||
|
||||
QQ_DEFAULT:
|
||||
REM ['cons, quasiquote(ast[0]), quasiquote(ast[1..])]
|
||||
|
||||
REM push T6 on the stack
|
||||
X=X+1:X%(X)=T6
|
||||
REM A set above to ast[0]
|
||||
CALL QUASIQUOTE
|
||||
B2=R
|
||||
REM pop T6 off the stack
|
||||
T6=X%(X):X=X-1
|
||||
|
||||
AS$="cons":T=5:GOSUB STRING:B3=R
|
||||
B1=T6:GOSUB LIST3
|
||||
REM release inner quasiquoted since outer list takes ownership
|
||||
AY=B1:GOSUB RELEASE
|
||||
AY=B2:GOSUB RELEASE
|
||||
AY=B3:GOSUB RELEASE
|
||||
QQ_DONE:
|
||||
END SUB
|
||||
|
||||
REM MACROEXPAND(A, E) -> A:
|
||||
SUB MACROEXPAND
|
||||
REM push original A
|
||||
X=X+1:X%(X)=A
|
||||
|
||||
MACROEXPAND_LOOP:
|
||||
REM list?
|
||||
IF (Z%(A,0)AND 31)<>6 THEN GOTO MACROEXPAND_DONE
|
||||
REM non-empty?
|
||||
IF Z%(A,1)=0 THEN GOTO MACROEXPAND_DONE
|
||||
B=A+1:GOSUB DEREF_B
|
||||
REM symbol? in first position
|
||||
IF (Z%(B,0)AND 31)<>5 THEN GOTO MACROEXPAND_DONE
|
||||
REM defined in environment?
|
||||
K=B:CALL ENV_FIND
|
||||
IF R=-1 THEN GOTO MACROEXPAND_DONE
|
||||
B=T4:GOSUB DEREF_B
|
||||
REM macro?
|
||||
IF (Z%(B,0)AND 31)<>11 THEN GOTO MACROEXPAND_DONE
|
||||
|
||||
F=B:AR=Z%(A,1):CALL APPLY
|
||||
A=R
|
||||
|
||||
AY=X%(X)
|
||||
REM if previous A was not the first A into macroexpand (i.e. an
|
||||
REM intermediate form) then free it
|
||||
IF A<>AY THEN Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV
|
||||
|
||||
IF ER<>-2 THEN GOTO MACROEXPAND_DONE
|
||||
GOTO MACROEXPAND_LOOP
|
||||
|
||||
MACROEXPAND_DONE:
|
||||
X=X-1: REM pop original A
|
||||
END SUB
|
||||
|
||||
REM EVAL_AST(A, E) -> R
|
||||
SUB EVAL_AST
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_RETURN
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
T=Z%(A,0)AND 31
|
||||
IF T=5 THEN GOTO EVAL_AST_SYMBOL
|
||||
IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ
|
||||
|
||||
REM scalar: deref to actual value and inc ref cnt
|
||||
R=A:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SYMBOL:
|
||||
K=A:GOTO ENV_GET
|
||||
ENV_GET_RETURN:
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_SEQ:
|
||||
REM allocate the first entry (T already set above)
|
||||
L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM make space on the stack
|
||||
X=X+4
|
||||
REM push type of sequence
|
||||
X%(X-3)=T
|
||||
REM push sequence index
|
||||
X%(X-2)=-1
|
||||
REM push future return value (new sequence)
|
||||
X%(X-1)=R
|
||||
REM push previous new sequence entry
|
||||
X%(X)=R
|
||||
|
||||
EVAL_AST_SEQ_LOOP:
|
||||
REM update index
|
||||
X%(X-2)=X%(X-2)+1
|
||||
|
||||
REM check if we are done evaluating the source sequence
|
||||
IF Z%(A,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if we are returning to DO, then skip last element
|
||||
IF X%(X-6)=2 AND Z%(Z%(A,1),1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM if hashmap, skip eval of even entries (keys)
|
||||
IF (X%(X-3)=8) AND ((X%(X-2)AND 1)=0) THEN GOTO EVAL_AST_DO_REF
|
||||
GOTO EVAL_AST_DO_EVAL
|
||||
|
||||
EVAL_AST_DO_REF:
|
||||
R=A+1:GOSUB DEREF_R: REM deref to target of referred entry
|
||||
Z%(R,0)=Z%(R,0)+32: REM inc ref cnt of referred value
|
||||
GOTO EVAL_AST_ADD_VALUE
|
||||
|
||||
EVAL_AST_DO_EVAL:
|
||||
REM call EVAL for each entry
|
||||
A=A+1:CALL EVAL
|
||||
A=A-1
|
||||
GOSUB DEREF_R: REM deref to target of evaluated entry
|
||||
|
||||
EVAL_AST_ADD_VALUE:
|
||||
|
||||
REM update previous value pointer to evaluated entry
|
||||
Z%(X%(X)+1,1)=R
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
|
||||
|
||||
REM allocate the next entry
|
||||
REM same new sequence entry type
|
||||
T=X%(X-3):L=0:N=0:GOSUB ALLOC
|
||||
|
||||
REM update previous sequence entry value to point to new entry
|
||||
Z%(X%(X),1)=R
|
||||
REM update previous ptr to current entry
|
||||
X%(X)=R
|
||||
|
||||
REM process the next sequence entry from source list
|
||||
A=Z%(A,1)
|
||||
|
||||
GOTO EVAL_AST_SEQ_LOOP
|
||||
EVAL_AST_SEQ_LOOP_DONE:
|
||||
REM if no error, get return value (new seq)
|
||||
IF ER=-2 THEN R=X%(X-1)
|
||||
REM otherwise, free the return value and return nil
|
||||
IF ER<>-2 THEN R=0:AY=X%(X-1):GOSUB RELEASE
|
||||
|
||||
REM pop previous, return, index and type
|
||||
X=X-4
|
||||
GOTO EVAL_AST_RETURN
|
||||
|
||||
EVAL_AST_RETURN:
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
END SUB
|
||||
|
||||
REM EVAL(A, E) -> R
|
||||
SUB EVAL
|
||||
LV=LV+1: REM track basic return stack level
|
||||
|
||||
REM push A and E on the stack
|
||||
X=X+2:X%(X-1)=E:X%(X)=A
|
||||
|
||||
REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0))
|
||||
|
||||
EVAL_TCO_RECUR:
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM AZ=A:PR=1:GOSUB PR_STR
|
||||
REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
|
||||
|
||||
GOSUB DEREF_A
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R THEN GOTO APPLY_LIST
|
||||
EVAL_NOT_LIST:
|
||||
REM ELSE
|
||||
CALL EVAL_AST
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
APPLY_LIST:
|
||||
CALL MACROEXPAND
|
||||
|
||||
GOSUB LIST_Q
|
||||
IF R<>1 THEN GOTO EVAL_NOT_LIST
|
||||
|
||||
GOSUB EMPTY_Q
|
||||
IF R THEN R=A:Z%(R,0)=Z%(R,0)+32:GOTO EVAL_RETURN
|
||||
|
||||
A0=A+1
|
||||
R=A0:GOSUB DEREF_R:A0=R
|
||||
|
||||
REM get symbol in A$
|
||||
IF (Z%(A0,0)AND 31)<>5 THEN A$=""
|
||||
IF (Z%(A0,0)AND 31)=5 THEN A$=S$(Z%(A0,1))
|
||||
|
||||
IF A$="def!" THEN GOTO EVAL_DEF
|
||||
IF A$="let*" THEN GOTO EVAL_LET
|
||||
IF A$="quote" THEN GOTO EVAL_QUOTE
|
||||
IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE
|
||||
IF A$="defmacro!" THEN GOTO EVAL_DEFMACRO
|
||||
IF A$="macroexpand" THEN GOTO EVAL_MACROEXPAND
|
||||
IF A$="try*" THEN GOTO EVAL_TRY
|
||||
IF A$="do" THEN GOTO EVAL_DO
|
||||
IF A$="if" THEN GOTO EVAL_IF
|
||||
IF A$="fn*" THEN GOTO EVAL_FN
|
||||
GOTO EVAL_INVOKE
|
||||
|
||||
EVAL_GET_A3:
|
||||
A3=Z%(Z%(Z%(A,1),1),1)+1
|
||||
R=A3:GOSUB DEREF_R:A3=R
|
||||
EVAL_GET_A2:
|
||||
A2=Z%(Z%(A,1),1)+1
|
||||
R=A2:GOSUB DEREF_R:A2=R
|
||||
EVAL_GET_A1:
|
||||
A1=Z%(A,1)+1
|
||||
R=A1:GOSUB DEREF_R:A1=R
|
||||
RETURN
|
||||
|
||||
EVAL_DEF:
|
||||
REM PRINT "def!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval a2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM set a1 in env to a2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_LET:
|
||||
REM PRINT "let*"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A2: REM push/save A2
|
||||
X=X+1:X%(X)=E: REM push env for for later release
|
||||
|
||||
REM create new environment with outer as current environment
|
||||
O=E:GOSUB ENV_NEW
|
||||
E=R
|
||||
EVAL_LET_LOOP:
|
||||
IF Z%(A1,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
REM eval current A1 odd element
|
||||
A=Z%(A1,1)+1:CALL EVAL
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE
|
||||
|
||||
REM set environment: even A1 key to odd A1 eval'd above
|
||||
K=A1+1:V=R:GOSUB ENV_SET
|
||||
AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership
|
||||
|
||||
REM skip to the next pair of A1 elements
|
||||
A1=Z%(Z%(A1,1),1)
|
||||
GOTO EVAL_LET_LOOP
|
||||
|
||||
EVAL_LET_LOOP_DONE:
|
||||
E4=X%(X):X=X-1: REM pop previous env
|
||||
|
||||
REM release previous environment if not the current EVAL env
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
A2=X%(X):X=X-1: REM pop A2
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_DO:
|
||||
A=Z%(A,1): REM rest
|
||||
X=X+1:X%(X)=A: REM push/save A
|
||||
|
||||
CALL EVAL_AST
|
||||
|
||||
REM cleanup
|
||||
AY=R: REM get eval'd list for release
|
||||
|
||||
A=X%(X):X=X-1: REM pop/restore original A for LAST
|
||||
GOSUB LAST: REM get last element for return
|
||||
A=R: REM new recur AST
|
||||
|
||||
REM cleanup
|
||||
GOSUB RELEASE: REM release eval'd list
|
||||
AY=A:GOSUB RELEASE: REM release LAST value (not sure why)
|
||||
|
||||
GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_QUOTE:
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_QUASIQUOTE:
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
A=R:CALL QUASIQUOTE
|
||||
REM add quasiquote result to pending release queue to free when
|
||||
REM next lower EVAL level returns (LV)
|
||||
Y=Y+1:Y%(Y,0)=R:Y%(Y,1)=LV
|
||||
|
||||
A=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_DEFMACRO:
|
||||
REM PRINT "defmacro!"
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
|
||||
X=X+1:X%(X)=A1: REM push A1
|
||||
A=A2:CALL EVAL: REM eval A2
|
||||
A1=X%(X):X=X-1: REM pop A1
|
||||
|
||||
REM change function to macro
|
||||
Z%(R,0)=Z%(R,0)+1
|
||||
|
||||
REM set A1 in env to A2
|
||||
K=A1:V=R:GOSUB ENV_SET
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_MACROEXPAND:
|
||||
REM PRINT "macroexpand"
|
||||
R=Z%(A,1)+1:GOSUB DEREF_R
|
||||
A=R:CALL MACROEXPAND
|
||||
R=A
|
||||
|
||||
REM since we are returning it unevaluated, inc the ref cnt
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_TRY:
|
||||
REM PRINT "try*"
|
||||
GOSUB EVAL_GET_A1: REM set A1, A2, and A3
|
||||
|
||||
X=X+1:X%(X)=A: REM push/save A
|
||||
A=A1:CALL EVAL: REM eval A1
|
||||
A=X%(X):X=X-1: REM pop/restore A
|
||||
|
||||
REM if there is not error or catch block then return
|
||||
IF ER=-2 OR Z%(A,1)=0 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM create environment for the catch block eval
|
||||
O=E:GOSUB ENV_NEW:E=R
|
||||
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
A=A2:GOSUB EVAL_GET_A2: REM set A1 and A2 from catch block
|
||||
|
||||
REM create object for ER=-1 type raw string errors
|
||||
IF ER=-1 THEN AS$=ER$:T=4:GOSUB STRING:ER=R:Z%(R,0)=Z%(R,0)+32
|
||||
|
||||
REM bind the catch symbol to the error object
|
||||
K=A1:V=ER:GOSUB ENV_SET
|
||||
AY=R:GOSUB RELEASE: REM release our use, env took ownership
|
||||
|
||||
REM unset error for catch eval
|
||||
ER=-2:ER$=""
|
||||
|
||||
A=A2:CALL EVAL
|
||||
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_IF:
|
||||
GOSUB EVAL_GET_A1: REM set A1
|
||||
REM push A
|
||||
X=X+1:X%(X)=A
|
||||
A=A1:CALL EVAL
|
||||
REM pop A
|
||||
A=X%(X):X=X-1
|
||||
IF (R=0) OR (R=1) THEN GOTO EVAL_IF_FALSE
|
||||
|
||||
EVAL_IF_TRUE:
|
||||
AY=R:GOSUB RELEASE
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL
|
||||
A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
EVAL_IF_FALSE:
|
||||
AY=R:GOSUB RELEASE
|
||||
REM if no false case (A3), return nil
|
||||
B=A:GOSUB COUNT
|
||||
IF R<4 THEN R=0:GOTO EVAL_RETURN
|
||||
GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL
|
||||
A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_FN:
|
||||
GOSUB EVAL_GET_A2: REM set A1 and A2
|
||||
A=A2:P=A1:GOSUB MAL_FUNCTION
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_INVOKE:
|
||||
CALL EVAL_AST
|
||||
|
||||
REM if error, return f/args for release by caller
|
||||
IF ER<>-2 THEN GOTO EVAL_RETURN
|
||||
|
||||
REM push f/args for release after call
|
||||
X=X+1:X%(X)=R
|
||||
|
||||
F=R+1
|
||||
|
||||
AR=Z%(R,1): REM rest
|
||||
R=F:GOSUB DEREF_R:F=R
|
||||
|
||||
REM if metadata, get the actual object
|
||||
IF (Z%(F,0)AND 31)>=16 THEN F=Z%(F,1)
|
||||
|
||||
IF (Z%(F,0)AND 31)=9 THEN GOTO EVAL_DO_FUNCTION
|
||||
IF (Z%(F,0)AND 31)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
|
||||
|
||||
REM if error, pop and return f/args for release by caller
|
||||
R=X%(X):X=X-1
|
||||
ER=-1:ER$="apply of non-function":GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_FUNCTION:
|
||||
REM regular function
|
||||
IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
|
||||
REM for recur functions (apply, map, swap!), use GOTO
|
||||
IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
|
||||
EVAL_DO_FUNCTION_SKIP:
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
GOTO EVAL_RETURN
|
||||
|
||||
EVAL_DO_MAL_FUNCTION:
|
||||
E4=E: REM save the current environment for release
|
||||
|
||||
REM create new environ using env stored with function
|
||||
O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
|
||||
|
||||
REM release previous env if it is not the top one on the
|
||||
REM stack (X%(X-2)) because our new env refers to it and
|
||||
REM we no longer need to track it (since we are TCO recurring)
|
||||
IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
|
||||
|
||||
REM claim the AST before releasing the list containing it
|
||||
A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
|
||||
REM add AST to pending release queue to free as soon as EVAL
|
||||
REM actually returns (LV+1)
|
||||
Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV+1
|
||||
|
||||
REM pop and release f/args
|
||||
AY=X%(X):X=X-1:GOSUB RELEASE
|
||||
|
||||
REM A set above
|
||||
E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
|
||||
|
||||
EVAL_RETURN:
|
||||
REM AZ=R: PR=1: GOSUB PR_STR
|
||||
REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER)
|
||||
|
||||
REM release environment if not the top one on the stack
|
||||
IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
|
||||
|
||||
LV=LV-1: REM track basic return stack level
|
||||
|
||||
REM release everything we couldn't release earlier
|
||||
GOSUB RELEASE_PEND
|
||||
|
||||
REM trigger GC
|
||||
#cbm TA=FRE(0)
|
||||
#qbasic TA=0
|
||||
|
||||
REM pop A and E off the stack
|
||||
E=X%(X-1):A=X%(X):X=X-2
|
||||
|
||||
END SUB
|
||||
|
||||
REM PRINT(A) -> R$
|
||||
MAL_PRINT:
|
||||
AZ=A:PR=1:GOSUB PR_STR
|
||||
RETURN
|
||||
|
||||
REM RE(A$) -> R
|
||||
REM Assume D has repl_env
|
||||
REM caller must release result
|
||||
RE:
|
||||
R1=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO RE_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
|
||||
RE_DONE:
|
||||
REM Release memory from MAL_READ
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
RETURN: REM caller must release result of EVAL
|
||||
|
||||
REM REP(A$) -> R$
|
||||
REM Assume D has repl_env
|
||||
SUB REP
|
||||
R1=0:R2=0
|
||||
GOSUB MAL_READ
|
||||
R1=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:E=D:CALL EVAL
|
||||
R2=R
|
||||
IF ER<>-2 THEN GOTO REP_DONE
|
||||
|
||||
A=R:GOSUB MAL_PRINT
|
||||
RT$=R$
|
||||
|
||||
REP_DONE:
|
||||
REM Release memory from MAL_READ and EVAL
|
||||
IF R2<>0 THEN AY=R2:GOSUB RELEASE
|
||||
IF R1<>0 THEN AY=R1:GOSUB RELEASE
|
||||
R$=RT$
|
||||
END SUB
|
||||
|
||||
REM MAIN program
|
||||
MAIN:
|
||||
GOSUB INIT_MEMORY
|
||||
|
||||
LV=0
|
||||
|
||||
REM create repl_env
|
||||
O=-1:GOSUB ENV_NEW:D=R
|
||||
|
||||
REM core.EXT: defined in Basic
|
||||
E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
|
||||
|
||||
ZT=ZI: REM top of memory after base repl_env
|
||||
|
||||
REM core.mal: defined using the language itself
|
||||
#cbm A$="(def! *host-language* "+CHR$(34)+"C64 Basic"+CHR$(34)+")"
|
||||
#qbasic A$="(def! *host-language* "+CHR$(34)+"QBasic"+CHR$(34)+")"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(def! not (fn* (a) (if a false true)))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(def! load-file (fn* (f) (eval (read-file f))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)"
|
||||
A$=A$+" (if (> (count xs) 1) (nth xs 1) (throw "+CHR$(34)+"odd number of"
|
||||
A$=A$+" forms to cond"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(def! *gensym-counter* (atom 0))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(def! gensym (fn* [] (symbol (str "+CHR$(34)+"G__"+CHR$(34)
|
||||
A$=A$+" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
A$="(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs)"
|
||||
A$=A$+" (let* (condvar (gensym)) `(let* (~condvar ~(first xs))"
|
||||
A$=A$+" (if ~condvar ~condvar (or ~@(rest xs)))))))))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM load the args file
|
||||
A$="(def! -*ARGS*- (load-file "+CHR$(34)+".args.mal"+CHR$(34)+"))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM set the argument list
|
||||
A$="(def! *ARGV* (rest -*ARGS*-))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REM get the first argument
|
||||
A$="(first -*ARGS*-)"
|
||||
GOSUB RE
|
||||
|
||||
REM if there is an argument, then run it as a program
|
||||
IF R<>0 THEN AY=R:GOSUB RELEASE:GOTO RUN_PROG
|
||||
REM no arguments, start REPL loop
|
||||
IF R=0 THEN GOTO REPL
|
||||
|
||||
RUN_PROG:
|
||||
REM run a single mal program and exit
|
||||
A$="(load-file (first -*ARGS*-))"
|
||||
GOSUB RE
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR
|
||||
GOTO QUIT
|
||||
|
||||
REPL:
|
||||
REM print the REPL startup header
|
||||
A$="(println (str "+CHR$(34)+"Mal ["+CHR$(34)+" *host-language* "
|
||||
A$=A$+CHR$(34)+"]"+CHR$(34)+"))"
|
||||
GOSUB RE:AY=R:GOSUB RELEASE
|
||||
|
||||
REPL_LOOP:
|
||||
A$="user> ":GOSUB READLINE: REM call input parser
|
||||
IF EZ=1 THEN GOTO QUIT
|
||||
|
||||
A$=R$:CALL REP: REM call REP
|
||||
|
||||
IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
|
||||
PRINT R$
|
||||
GOTO REPL_LOOP
|
||||
|
||||
QUIT:
|
||||
GOSUB PR_MEMORY_SUMMARY
|
||||
END
|
||||
|
||||
PRINT_ERROR:
|
||||
REM if the error is an object, then print and free it
|
||||
IF ER>=0 THEN AZ=ER:PR=0:GOSUB PR_STR:ER$=R$:AY=ER:GOSUB RELEASE
|
||||
PRINT "Error: "+ER$
|
||||
ER=-2:ER$=""
|
||||
RETURN
|
||||
|
531
basic/types.in.bas
Normal file
531
basic/types.in.bas
Normal file
@ -0,0 +1,531 @@
|
||||
REM Z 0 -> 1
|
||||
REM nil 0 -> (unused)
|
||||
REM boolean 1 -> 0: false, 1: true
|
||||
REM integer 2 -> int value
|
||||
REM float 3 -> ???
|
||||
REM string/kw 4 -> S$ index
|
||||
REM symbol 5 -> S$ index
|
||||
REM list next/val 6 -> next Z% index (0 for last)
|
||||
REM 14 value (unless empty)
|
||||
REM vector next/val 7 -> next Z% index (0 for last)
|
||||
REM 14 value (unless empty)
|
||||
REM hashmap next/val 8 -> next Z% index (0 for last)
|
||||
REM 14 key/value (alternating)
|
||||
REM function 9 -> function index
|
||||
REM mal function 10 -> body AST Z% index
|
||||
REM param env Z% index
|
||||
REM macro (same as 10) 11 -> body AST Z% index
|
||||
REM param env Z% index
|
||||
REM atom 12 -> Z% index
|
||||
REM environment 13 -> data/hashmap Z% index
|
||||
REM 14 outer Z% index (-1 for none)
|
||||
REM reference/ptr 14 -> Z% index / or 0
|
||||
REM next free ptr 15 -> Z% index / or 0
|
||||
REM metadata 16-31 -> Z% index of object with this metadata
|
||||
REM 14 -> Z% index of metdata object
|
||||
|
||||
INIT_MEMORY:
|
||||
#cbm TA=FRE(0)
|
||||
#qbasic TA=0
|
||||
|
||||
Z1=2048+1024+256: REM Z% (boxed memory) size (4 bytes each)
|
||||
Z2=256: REM S$ (string memory) size (3 bytes each)
|
||||
Z3=256: REM X% (call stack) size (2 bytes each)
|
||||
Z4=64: REM Y% (release stack) size (4 bytes each)
|
||||
|
||||
REM global error state
|
||||
REM -2 : no error
|
||||
REM -1 : string error in ER$
|
||||
REM >=0 : pointer to error object
|
||||
ER=-2
|
||||
ER$=""
|
||||
|
||||
REM boxed element memory
|
||||
DIM Z%(Z1,1): REM TYPE ARRAY
|
||||
|
||||
REM Predefine nil, false, true, and an empty list
|
||||
Z%(0,0)=0:Z%(0,1)=0
|
||||
Z%(1,0)=1:Z%(1,1)=0
|
||||
Z%(2,0)=1:Z%(2,1)=1
|
||||
Z%(3,0)=6+32:Z%(3,1)=0
|
||||
Z%(4,0)=0:Z%(4,1)=0
|
||||
Z%(5,0)=7+32:Z%(5,1)=0
|
||||
Z%(6,0)=0:Z%(6,1)=0
|
||||
Z%(7,0)=8+32:Z%(7,1)=0
|
||||
Z%(8,0)=0:Z%(8,1)=0
|
||||
|
||||
REM start of unused memory
|
||||
ZI=9
|
||||
|
||||
REM start of free list
|
||||
ZK=9
|
||||
|
||||
REM string memory storage
|
||||
S=0:DIM S$(Z2)
|
||||
|
||||
REM call/logic stack
|
||||
X=-1:DIM X%(Z3): REM stack of Z% indexes
|
||||
|
||||
REM pending release stack
|
||||
Y=-1:DIM Y%(Z4,1): REM stack of Z% indexes
|
||||
|
||||
BT=TI
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
REM memory functions
|
||||
|
||||
REM ALLOC(T,L) -> R
|
||||
REM ALLOC(T,L,N) -> R
|
||||
REM ALLOC(T,L,M,N) -> R
|
||||
REM L is default for Z%(R,1)
|
||||
REM M is default for Z%(R+1,0), if relevant for T
|
||||
REM N is default for Z%(R+1,1), if relevant for T
|
||||
ALLOC:
|
||||
SZ=2
|
||||
IF T<6 OR T=9 OR T=12 OR T=14 THEN SZ=1
|
||||
REM PRINT "ALLOC T: "+STR$(T)+", SZ: "+STR$(SZ)+", ZK: "+STR$(ZK)
|
||||
U3=ZK
|
||||
U4=ZK
|
||||
ALLOC_LOOP:
|
||||
IF U4=ZI THEN GOTO ALLOC_UNUSED
|
||||
REM TODO sanity check that type is 15
|
||||
IF ((Z%(U4,0)AND-32)/32)=SZ THEN GOTO ALLOC_MIDDLE
|
||||
REM PRINT "ALLOC search: U3: "+STR$(U3)+", U4: "+STR$(U4)
|
||||
U3=U4: REM previous set to current
|
||||
U4=Z%(U4,1): REM current set to next
|
||||
GOTO ALLOC_LOOP
|
||||
ALLOC_MIDDLE:
|
||||
REM PRINT "ALLOC_MIDDLE: U3: "+STR$(U3)+", U4: "+STR$(U4)
|
||||
R=U4
|
||||
REM set free pointer (ZK) to next free
|
||||
IF U4=ZK THEN ZK=Z%(U4,1)
|
||||
REM set previous free to next free
|
||||
IF U4<>ZK THEN Z%(U3,1)=Z%(U4,1)
|
||||
GOTO ALLOC_DONE
|
||||
ALLOC_UNUSED:
|
||||
REM PRINT "ALLOC_UNUSED ZI: "+STR$(ZI)+", U3: "+STR$(U3)+", U4: "+STR$(U4)
|
||||
R=U4
|
||||
ZI=ZI+SZ
|
||||
IF U3=U4 THEN ZK=ZI
|
||||
REM set previous free to new memory top
|
||||
IF U3<>U4 THEN Z%(U3,1)=ZI
|
||||
GOTO ALLOC_DONE
|
||||
ALLOC_DONE:
|
||||
Z%(R,0)=T+32
|
||||
REM set Z%(R,1) to default L
|
||||
IF T>=6 AND T<>9 AND L>0 THEN Z%(L,0)=Z%(L,0)+32
|
||||
Z%(R,1)=L
|
||||
|
||||
IF SZ=1 THEN RETURN
|
||||
Z%(R+1,0)=14: REM default for 6-8, and 13, and >=16 (metadata)
|
||||
|
||||
REM function/macro sets Z%(R+1,0) to default M
|
||||
IF T=10 OR T=11 THEN Z%(M,0)=Z%(M,0)+32:Z%(R+1,0)=M
|
||||
|
||||
REM seq, function/macro, environment sets Z%(R+1,1) to default N
|
||||
IF N>0 THEN Z%(N,0)=Z%(N,0)+32
|
||||
Z%(R+1,1)=N
|
||||
RETURN
|
||||
|
||||
REM FREE(AY, SZ) -> nil
|
||||
FREE:
|
||||
REM assumes reference count cleanup already (see RELEASE)
|
||||
Z%(AY,0)=(SZ*32)+15: REM set type(15) and size
|
||||
Z%(AY,1)=ZK
|
||||
ZK=AY
|
||||
IF SZ>=2 THEN Z%(AY+1,0)=0:Z%(AY+1,1)=0
|
||||
IF SZ>=3 THEN Z%(AY+2,0)=0:Z%(AY+2,1)=0
|
||||
RETURN
|
||||
|
||||
|
||||
REM RELEASE(AY) -> nil
|
||||
REM R should not be affected by this call
|
||||
RELEASE:
|
||||
RC=0
|
||||
|
||||
GOTO RELEASE_ONE
|
||||
|
||||
RELEASE_TOP:
|
||||
|
||||
IF RC=0 THEN RETURN
|
||||
|
||||
REM pop next object to release, decrease remaining count
|
||||
AY=X%(X):X=X-1
|
||||
RC=RC-1
|
||||
|
||||
RELEASE_ONE:
|
||||
|
||||
REM nil, false, true
|
||||
IF AY<3 THEN GOTO RELEASE_TOP
|
||||
|
||||
U6=Z%(AY,0)AND 31: REM type
|
||||
|
||||
REM AZ=AY: PR=1: GOSUB PR_STR
|
||||
REM PRINT "RELEASE AY:"+STR$(AY)+"["+R$+"] (byte0:"+STR$(Z%(AY,0))+")"
|
||||
|
||||
REM sanity check not already freed
|
||||
IF (U6)=15 THEN ER=-1:ER$="Free of free memory: "+STR$(AY):RETURN
|
||||
IF U6=14 THEN GOTO RELEASE_REFERENCE
|
||||
IF Z%(AY,0)<15 THEN ER=-1:ER$="Free of freed object: "+STR$(AY):RETURN
|
||||
|
||||
REM decrease reference count by one
|
||||
Z%(AY,0)=Z%(AY,0)-32
|
||||
|
||||
REM our reference count is not 0, so don't release
|
||||
IF Z%(AY,0)>=32 GOTO RELEASE_TOP
|
||||
|
||||
REM switch on type
|
||||
IF (U6<=5) OR (U6=9) THEN GOTO RELEASE_SIMPLE
|
||||
IF (U6>=6) AND (U6<=8) THEN GOTO RELEASE_SEQ
|
||||
IF U6=10 OR U6=11 THEN GOTO RELEASE_MAL_FUNCTION
|
||||
IF U6>=16 THEN GOTO RELEASE_METADATA
|
||||
IF U6=12 THEN GOTO RELEASE_ATOM
|
||||
IF U6=13 THEN GOTO RELEASE_ENV
|
||||
IF U6=15 THEN ER=-1:ER$="RELEASE of already freed: "+STR$(AY):RETURN
|
||||
ER=-1:ER$="RELEASE not defined for type "+STR$(U6):RETURN
|
||||
|
||||
RELEASE_SIMPLE:
|
||||
REM simple type (no recursing), just call FREE on it
|
||||
SZ=1:GOSUB FREE
|
||||
GOTO RELEASE_TOP
|
||||
RELEASE_SIMPLE_2:
|
||||
REM free the current element and continue
|
||||
SZ=2:GOSUB FREE
|
||||
GOTO RELEASE_TOP
|
||||
RELEASE_SEQ:
|
||||
IF Z%(AY,1)=0 THEN GOTO RELEASE_SIMPLE_2
|
||||
IF Z%(AY+1,0)<>14 THEN ER=-1:ER$="invalid list value"+STR$(AY+1):RETURN
|
||||
REM add value and next element to stack
|
||||
RC=RC+2:X=X+2
|
||||
X%(X-1)=Z%(AY+1,1):X%(X)=Z%(AY,1)
|
||||
GOTO RELEASE_SIMPLE_2
|
||||
RELEASE_ATOM:
|
||||
REM add contained/referred value
|
||||
RC=RC+1:X=X+1:X%(X)=Z%(AY,1)
|
||||
REM free the atom itself
|
||||
GOTO RELEASE_SIMPLE
|
||||
RELEASE_MAL_FUNCTION:
|
||||
REM add ast, params and environment to stack
|
||||
RC=RC+3:X=X+3
|
||||
X%(X-2)=Z%(AY,1):X%(X-1)=Z%(AY+1,0):X%(X)=Z%(AY+1,1)
|
||||
REM free the current 2 element mal_function and continue
|
||||
SZ=2:GOSUB FREE
|
||||
GOTO RELEASE_TOP
|
||||
RELEASE_METADATA:
|
||||
REM add object and metadata object
|
||||
RC=RC+2:X=X+2
|
||||
X%(X-1)=Z%(AY,1):X%(X)=Z%(AY+1,1)
|
||||
SZ=2:GOSUB FREE
|
||||
GOTO RELEASE_TOP
|
||||
RELEASE_ENV:
|
||||
REM add the hashmap data to the stack
|
||||
RC=RC+1:X=X+1:X%(X)=Z%(AY,1)
|
||||
REM if no outer set
|
||||
IF Z%(AY+1,1)=-1 THEN GOTO RELEASE_ENV_FREE
|
||||
REM add outer environment to the stack
|
||||
RC=RC+1:X=X+1:X%(X)=Z%(AY+1,1)
|
||||
RELEASE_ENV_FREE:
|
||||
REM free the current 2 element environment and continue
|
||||
SZ=2:GOSUB FREE
|
||||
GOTO RELEASE_TOP
|
||||
RELEASE_REFERENCE:
|
||||
IF Z%(AY,1)=0 THEN GOTO RELEASE_SIMPLE
|
||||
REM add the referred element to the stack
|
||||
RC=RC+1:X=X+1:X%(X)=Z%(AY,1)
|
||||
REM free the current element and continue
|
||||
SZ=1:GOSUB FREE
|
||||
GOTO RELEASE_TOP
|
||||
|
||||
REM RELEASE_PEND(LV) -> nil
|
||||
RELEASE_PEND:
|
||||
IF Y<0 THEN RETURN
|
||||
IF Y%(Y,1)<=LV THEN RETURN
|
||||
REM PRINT "RELEASE_PEND releasing:"+STR$(Y%(Y,0))
|
||||
AY=Y%(Y,0):GOSUB RELEASE
|
||||
Y=Y-1
|
||||
GOTO RELEASE_PEND
|
||||
|
||||
REM DEREF_R(R) -> R
|
||||
DEREF_R:
|
||||
IF (Z%(R,0)AND 31)=14 THEN R=Z%(R,1):GOTO DEREF_R
|
||||
RETURN
|
||||
|
||||
REM DEREF_A(A) -> A
|
||||
DEREF_A:
|
||||
IF (Z%(A,0)AND 31)=14 THEN A=Z%(A,1):GOTO DEREF_A
|
||||
RETURN
|
||||
|
||||
REM DEREF_B(B) -> B
|
||||
DEREF_B:
|
||||
IF (Z%(B,0)AND 31)=14 THEN B=Z%(B,1):GOTO DEREF_B
|
||||
RETURN
|
||||
|
||||
|
||||
REM general functions
|
||||
|
||||
REM EQUAL_Q(A, B) -> R
|
||||
EQUAL_Q:
|
||||
ED=0: REM recursion depth
|
||||
R=-1: REM return value
|
||||
|
||||
EQUAL_Q_RECUR:
|
||||
|
||||
GOSUB DEREF_A
|
||||
GOSUB DEREF_B
|
||||
|
||||
REM push A and B
|
||||
X=X+2:X%(X-1)=A:X%(X)=B
|
||||
ED=ED+1
|
||||
|
||||
U1=Z%(A,0)AND 31
|
||||
U2=Z%(B,0)AND 31
|
||||
IF U1>5 AND U1<8 AND U2>5 AND U2<8 THEN GOTO EQUAL_Q_SEQ
|
||||
IF U1=8 AND U2=8 THEN GOTO EQUAL_Q_HM
|
||||
|
||||
IF U1<>U2 OR Z%(A,1)<>Z%(B,1) THEN R=0
|
||||
GOTO EQUAL_Q_DONE
|
||||
|
||||
EQUAL_Q_SEQ:
|
||||
IF (Z%(A,1)=0) AND (Z%(B,1)=0) THEN GOTO EQUAL_Q_DONE
|
||||
IF (Z%(A,1)=0) OR (Z%(B,1)=0) THEN R=0:GOTO EQUAL_Q_DONE
|
||||
|
||||
REM compare the elements
|
||||
A=Z%(A+1,1):B=Z%(B+1,1)
|
||||
GOTO EQUAL_Q_RECUR
|
||||
|
||||
EQUAL_Q_SEQ_CONTINUE:
|
||||
REM next elements of the sequences
|
||||
A=X%(X-1):B=X%(X)
|
||||
A=Z%(A,1):B=Z%(B,1)
|
||||
X%(X-1)=A:X%(X)=B
|
||||
GOTO EQUAL_Q_SEQ
|
||||
|
||||
EQUAL_Q_HM:
|
||||
R=0
|
||||
GOTO EQUAL_Q_DONE
|
||||
|
||||
EQUAL_Q_DONE:
|
||||
X=X-2: REM pop current A and B
|
||||
ED=ED-1
|
||||
IF R>-1 AND ED>0 THEN GOTO EQUAL_Q_DONE: REM unwind
|
||||
IF ED=0 AND R=-1 THEN R=1
|
||||
IF ED=0 THEN RETURN
|
||||
GOTO EQUAL_Q_SEQ_CONTINUE
|
||||
|
||||
REM string functions
|
||||
|
||||
REM STRING_(AS$) -> R
|
||||
REM intern string (returns string index, not Z% index)
|
||||
STRING_:
|
||||
IF S=0 THEN GOTO STRING_NOT_FOUND
|
||||
|
||||
REM search for matching string in S$
|
||||
I=0
|
||||
STRING_LOOP:
|
||||
IF I>S-1 THEN GOTO STRING_NOT_FOUND
|
||||
IF AS$=S$(I) THEN R=I:RETURN
|
||||
I=I+1
|
||||
GOTO STRING_LOOP
|
||||
|
||||
STRING_NOT_FOUND:
|
||||
S$(S)=AS$
|
||||
R=S
|
||||
S=S+1
|
||||
RETURN
|
||||
|
||||
REM STRING(AS$, T) -> R
|
||||
REM intern string and allocate reference (return Z% index)
|
||||
STRING:
|
||||
GOSUB STRING_
|
||||
L=R:GOSUB ALLOC
|
||||
RETURN
|
||||
|
||||
REM REPLACE(R$, S1$, S2$) -> R$
|
||||
REPLACE:
|
||||
T3$=R$
|
||||
R$=""
|
||||
I=1
|
||||
J=LEN(T3$)
|
||||
REPLACE_LOOP:
|
||||
IF I>J THEN RETURN
|
||||
CH$=MID$(T3$,I,LEN(S1$))
|
||||
IF CH$=S1$ THEN R$=R$+S2$:I=I+LEN(S1$)
|
||||
IF CH$<>S1$ THEN R$=R$+MID$(T3$,I,1):I=I+1
|
||||
GOTO REPLACE_LOOP
|
||||
|
||||
|
||||
REM sequence functions
|
||||
|
||||
REM FORCE_SEQ_TYPE(A,T) -> R
|
||||
FORCE_SEQ_TYPE:
|
||||
REM if it's already the right type, inc ref cnt and return it
|
||||
IF (Z%(A,0)AND 31)=T THEN R=A:Z%(R,0)=Z%(R,0)+32:RETURN
|
||||
REM otherwise, copy first element to turn it into correct type
|
||||
B=A+1:GOSUB DEREF_B: REM value to copy
|
||||
L=Z%(A,1):N=B:GOSUB ALLOC: REM T already set
|
||||
IF Z%(A,1)=0 THEN RETURN
|
||||
RETURN
|
||||
|
||||
|
||||
REM LIST_Q(A) -> R
|
||||
LIST_Q:
|
||||
R=0
|
||||
IF (Z%(A,0)AND 31)=6 THEN R=1
|
||||
RETURN
|
||||
|
||||
REM EMPTY_Q(A) -> R
|
||||
EMPTY_Q:
|
||||
R=0
|
||||
IF Z%(A,1)=0 THEN R=1
|
||||
RETURN
|
||||
|
||||
REM COUNT(B) -> R
|
||||
REM - returns length of list, not a Z% index
|
||||
REM - modifies B
|
||||
COUNT:
|
||||
R=-1
|
||||
DO_COUNT_LOOP:
|
||||
R=R+1
|
||||
IF Z%(B,1)<>0 THEN B=Z%(B,1):GOTO DO_COUNT_LOOP
|
||||
RETURN
|
||||
|
||||
REM LAST(A) -> R
|
||||
LAST:
|
||||
REM TODO check that actually a list/vector
|
||||
IF Z%(A,1)=0 THEN R=0:RETURN: REM empty seq, return nil
|
||||
T6=0
|
||||
LAST_LOOP:
|
||||
IF Z%(A,1)=0 THEN GOTO LAST_DONE: REM end, return previous value
|
||||
T6=A: REM current becomes previous entry
|
||||
A=Z%(A,1): REM next entry
|
||||
GOTO LAST_LOOP
|
||||
LAST_DONE:
|
||||
R=T6+1:GOSUB DEREF_R
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
RETURN
|
||||
|
||||
REM SLICE(A,B,C) -> R
|
||||
REM make copy of sequence A from index B to C
|
||||
REM returns R6 as reference to last element of slice
|
||||
REM returns A as next element following slice (of original)
|
||||
SLICE:
|
||||
I=0
|
||||
R5=-1: REM temporary for return as R
|
||||
R6=0: REM previous list element
|
||||
SLICE_LOOP:
|
||||
REM always allocate at least one list element
|
||||
T=6:L=0:N=0:GOSUB ALLOC
|
||||
IF R5=-1 THEN R5=R
|
||||
IF R5<>-1 THEN Z%(R6,1)=R
|
||||
REM advance A to position B
|
||||
SLICE_FIND_B:
|
||||
IF I<B AND Z%(A,1)<>0 THEN A=Z%(A,1):I=I+1:GOTO SLICE_FIND_B
|
||||
REM if current position is C, then return
|
||||
IF C<>-1 AND I>=C THEN R=R5:RETURN
|
||||
REM if we reached end of A, then return
|
||||
IF Z%(A,1)=0 THEN R=R5:RETURN
|
||||
R6=R: REM save previous list element
|
||||
REM copy value and inc ref cnt
|
||||
Z%(R6+1,1)=Z%(A+1,1)
|
||||
R=A+1:GOSUB DEREF_R:Z%(R,0)=Z%(R,0)+32
|
||||
REM advance to next element of A
|
||||
A=Z%(A,1)
|
||||
I=I+1
|
||||
GOTO SLICE_LOOP
|
||||
|
||||
REM LIST2(B2,B1) -> R
|
||||
LIST2:
|
||||
REM last element is 3 (empty list), second element is B1
|
||||
T=6:L=3:N=B1:GOSUB ALLOC
|
||||
|
||||
REM first element is B2
|
||||
T=6:L=R:N=B2:GOSUB ALLOC
|
||||
AY=L:GOSUB RELEASE: REM new list takes ownership of previous
|
||||
|
||||
RETURN
|
||||
|
||||
REM LIST3(B3,B2,B1) -> R
|
||||
LIST3:
|
||||
GOSUB LIST2
|
||||
|
||||
REM first element is B3
|
||||
T=6:L=R:N=B3:GOSUB ALLOC
|
||||
AY=L:GOSUB RELEASE: REM new list takes ownership of previous
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
REM hashmap functions
|
||||
|
||||
REM HASHMAP() -> R
|
||||
HASHMAP:
|
||||
REM just point to static empty hash-map
|
||||
R=7
|
||||
Z%(R,0)=Z%(R,0)+32
|
||||
RETURN
|
||||
|
||||
REM ASSOC1(H, K, V) -> R
|
||||
ASSOC1:
|
||||
REM deref K and V
|
||||
R=V:GOSUB DEREF_R:V=R
|
||||
R=K:GOSUB DEREF_R:K=R
|
||||
|
||||
REM value ptr
|
||||
T=8:L=H:N=V:GOSUB ALLOC
|
||||
AY=L:GOSUB RELEASE: REM we took ownership of previous hashmap
|
||||
REM key ptr
|
||||
T=8:L=R:N=K:GOSUB ALLOC
|
||||
AY=L:GOSUB RELEASE: REM we took ownership of previous hashmap
|
||||
RETURN
|
||||
|
||||
REM ASSOC1(H, K$, V) -> R
|
||||
ASSOC1_S:
|
||||
S$(S)=K$
|
||||
REM add the key string
|
||||
T=4:L=S:GOSUB ALLOC
|
||||
S=S+1
|
||||
K=R:GOSUB ASSOC1
|
||||
AY=K:GOSUB RELEASE: REM map took ownership of key
|
||||
RETURN
|
||||
|
||||
REM HASHMAP_GET(H, K) -> R
|
||||
HASHMAP_GET:
|
||||
H2=H
|
||||
T1$=S$(Z%(K,1)): REM search key string
|
||||
T3=0: REM whether found or not (for HASHMAP_CONTAINS)
|
||||
R=0
|
||||
HASHMAP_GET_LOOP:
|
||||
REM no matching key found
|
||||
IF Z%(H2,1)=0 THEN R=0:RETURN
|
||||
REM follow value ptrs
|
||||
T2=H2+1
|
||||
HASHMAP_GET_DEREF:
|
||||
IF Z%(T2,0)=14 THEN T2=Z%(T2,1):GOTO HASHMAP_GET_DEREF
|
||||
REM get key string
|
||||
T2$=S$(Z%(T2,1))
|
||||
REM if they are equal, we found it
|
||||
IF T1$=T2$ THEN T3=1:R=Z%(H2,1)+1:RETURN
|
||||
REM skip to next key
|
||||
H2=Z%(Z%(H2,1),1)
|
||||
GOTO HASHMAP_GET_LOOP
|
||||
|
||||
REM HASHMAP_CONTAINS(H, K) -> R
|
||||
HASHMAP_CONTAINS:
|
||||
GOSUB HASHMAP_GET
|
||||
R=T3
|
||||
RETURN
|
||||
|
||||
|
||||
REM function functions
|
||||
|
||||
REM NATIVE_FUNCTION(A) -> R
|
||||
NATIVE_FUNCTION:
|
||||
T=9:L=A:GOSUB ALLOC
|
||||
RETURN
|
||||
|
||||
REM MAL_FUNCTION(A, P, E) -> R
|
||||
MAL_FUNCTION:
|
||||
T=10:L=A:M=P:N=E:GOSUB ALLOC
|
||||
RETURN
|
95
basic/variables.txt
Normal file
95
basic/variables.txt
Normal file
@ -0,0 +1,95 @@
|
||||
Global Unique:
|
||||
|
||||
Z% : boxed memory values
|
||||
ZI : start of unused memory (index into Z%)
|
||||
ZK : start of free list (index into Z%)
|
||||
ZT : top of memory after repl env allocations
|
||||
|
||||
S$ : string memory storage
|
||||
S : next free index in S$
|
||||
|
||||
X% : logic/call stack (Z% indexes)
|
||||
X : top element of X% stack
|
||||
|
||||
Y% : pending release stack [index into Z%, eval level]
|
||||
Y : top element of Y% stack
|
||||
|
||||
D : root repl environment
|
||||
|
||||
ER : error type (-2: none, -1: string, >=0: object)
|
||||
ER$ : error string (ER=-1)
|
||||
EZ : READLINE EOF
|
||||
|
||||
BI : ENV_NEW_BINDS binds list
|
||||
EX : ENV_NEW_BINDS expressions list
|
||||
LV : EVAL stack call level/depth
|
||||
|
||||
RI : reader current string position
|
||||
RJ : READ_TOKEN current character index
|
||||
|
||||
|
||||
Calling arguments/temporaries:
|
||||
|
||||
A : common call arguments (especially EVAL, EVAL_AST)
|
||||
B : common call arguments
|
||||
C : common call arguments
|
||||
E : environment (EVAL, EVAL_AST)
|
||||
F : function
|
||||
H : hash map
|
||||
K : hash map key (Z% index)
|
||||
K$ : hash map key string
|
||||
L : ALLOC* Z%(R,1) default
|
||||
M : ALLOC* Z%(R+1,0) default
|
||||
N : ALLOC* Z%(R+1,1) default
|
||||
O : outer environment
|
||||
P : MAL_FUNCTION
|
||||
R : common return value
|
||||
T : common temp, type
|
||||
V : hash map value
|
||||
|
||||
B1 : LIST2/LIST3 param
|
||||
B2 : LIST2/LIST3 param
|
||||
B3 : LIST3 param
|
||||
CZ : DO_CONCAT stack position
|
||||
EF : ENV_FIND cur env ptr
|
||||
P1 : PR_MEMORY, CHECK_FREE_LIST start
|
||||
P2 : PR_MEMORY, CHECK_FREE_LIST end
|
||||
SZ : size argument to ALLOC
|
||||
|
||||
Reused/temporaries:
|
||||
A0 : EVAL ast elements
|
||||
A1 : EVAL ast elements
|
||||
A2 : EVAL ast elements
|
||||
A3 : EVAL ast elements
|
||||
|
||||
ED : EQUAL_Q recursion depth counter
|
||||
RD : PR_OBJECT recursion depth
|
||||
SD : READ_STR sequence read recursion depth
|
||||
|
||||
CH$ : READ_TOKEN, SKIP_SPACES, SKIP_TO_EOL current character
|
||||
I : STRING, REPLACE, SLICE, PR_MEMORY, PR_OBJECT
|
||||
J : REPLACE
|
||||
S1 : READ_TOKEN in a string?
|
||||
S2 : READ_TOKEN escaped?
|
||||
T$ : READ_* current token string
|
||||
T1$ : HASHMAP_GET temp
|
||||
T2$ : HASHMAP_GET temp
|
||||
T1 : PR_STR, and core DO_KEYS_VALS temp
|
||||
T2 :
|
||||
T3 :
|
||||
T4 :
|
||||
T5 :
|
||||
T6 :
|
||||
T7 : READ_FORM and PR_STR temp
|
||||
T8 :
|
||||
T9 :
|
||||
TA :
|
||||
U1 :
|
||||
U2 :
|
||||
U3 :
|
||||
U4 :
|
||||
U6 :
|
||||
|
||||
Unused:
|
||||
|
||||
G, Q, U, W
|
@ -7,8 +7,8 @@
|
||||
(def! eval-ast (fn* [ast env] (do
|
||||
;;(do (prn "eval-ast" ast "/" (keys env)) )
|
||||
(cond
|
||||
(symbol? ast) (or (get env (str ast))
|
||||
(throw (str ast " not found")))
|
||||
(symbol? ast) (let* [res (get env (str ast))]
|
||||
(if res res (throw (str ast " not found"))))
|
||||
|
||||
(list? ast) (map (fn* [exp] (EVAL exp env)) ast)
|
||||
|
||||
|
@ -23,7 +23,7 @@ fi
|
||||
|
||||
root="$(dirname $0)"
|
||||
|
||||
out="$( $@ $root/tests/print_argv.mal aaa bbb ccc )"
|
||||
out="$( $@ $root/tests/print_argv.mal aaa bbb ccc | tr -d '\r' )"
|
||||
assert_equal '("aaa" "bbb" "ccc")' "$out"
|
||||
|
||||
# Note: The 'make' implementation cannot handle arguments with spaces in them,
|
||||
@ -32,7 +32,7 @@ assert_equal '("aaa" "bbb" "ccc")' "$out"
|
||||
# out="$( $@ $root/tests/print_argv.mal aaa 'bbb ccc' ddd )"
|
||||
# assert_equal '("aaa" "bbb ccc" "ddd")' "$out"
|
||||
|
||||
out="$( $@ $root/tests/print_argv.mal )"
|
||||
out="$( $@ $root/tests/print_argv.mal | tr -d '\r' )"
|
||||
assert_equal '()' "$out"
|
||||
|
||||
echo 'Passed all *ARGV* tests'
|
||||
|
@ -127,6 +127,7 @@ class Runner():
|
||||
self.buf += new_data.replace("\n", "\r\n")
|
||||
else:
|
||||
self.buf += new_data
|
||||
self.buf = self.buf.replace("\r\r", "\r")
|
||||
for prompt in prompts:
|
||||
regexp = re.compile(prompt)
|
||||
match = regexp.search(self.buf)
|
||||
|
@ -15,14 +15,4 @@
|
||||
(swap! atm (fn* [a] (concat (rest a) (list (first a)))))))
|
||||
10))
|
||||
|
||||
;;(def! sumdown (fn* (N) (if (> N 0) (+ N (sumdown (- N 1))) 0)))
|
||||
;;(def! fib (fn* (N) (if (= N 0) 1 (if (= N 1) 1 (+ (fib (- N 1)) (fib (- N 2)))))))
|
||||
;;
|
||||
;;(println "iters/s:"
|
||||
;; (run-fn-for
|
||||
;; (fn* []
|
||||
;; (do
|
||||
;; (sumdown 10)
|
||||
;; (fib 12)))
|
||||
;; 3))
|
||||
;;(prn "Done: basic macros/atom test")
|
||||
|
@ -27,6 +27,8 @@ abc-def
|
||||
;=>(+ 1 2)
|
||||
()
|
||||
;=>()
|
||||
(nil)
|
||||
;=>(nil)
|
||||
((3 4))
|
||||
;=>((3 4))
|
||||
(+ 1 (+ 2 3))
|
||||
@ -96,6 +98,8 @@ false
|
||||
;=>(unquote 1)
|
||||
~(1 2 3)
|
||||
;=>(unquote (1 2 3))
|
||||
`(1 ~a 3)
|
||||
;=>(quasiquote (1 (unquote a) 3))
|
||||
~@(1 2 3)
|
||||
;=>(splice-unquote (1 2 3))
|
||||
|
||||
|
@ -11,14 +11,14 @@
|
||||
(/ (- (+ 5 (* 2 3)) 3) 4)
|
||||
;=>2
|
||||
|
||||
(/ (- (+ 515 (* 222 311)) 302) 27)
|
||||
;=>2565
|
||||
(/ (- (+ 515 (* 87 311)) 302) 27)
|
||||
;=>1010
|
||||
|
||||
(* -3 6)
|
||||
;=>-18
|
||||
|
||||
(/ (- (+ 515 (* -222 311)) 296) 27)
|
||||
;=>-2549
|
||||
(/ (- (+ 515 (* -87 311)) 296) 27)
|
||||
;=>-994
|
||||
|
||||
(abc 1 2 3)
|
||||
; .*\'abc\' not found.*
|
||||
|
@ -29,6 +29,14 @@ mynum
|
||||
MYNUM
|
||||
;=>222
|
||||
|
||||
;; Check env lookup non-fatal error
|
||||
(abc 1 2 3)
|
||||
; .*\'abc\' not found.*
|
||||
;; Check that error aborts def!
|
||||
(def! w 123)
|
||||
(def! w (abc))
|
||||
w
|
||||
;=>123
|
||||
|
||||
;; Testing let*
|
||||
(let* (z 9) z)
|
||||
@ -41,6 +49,9 @@ x
|
||||
;=>6
|
||||
(let* (p (+ 2 3) q (+ 2 p)) (+ p q))
|
||||
;=>12
|
||||
(def! y (let* (z 7) z))
|
||||
y
|
||||
;=>7
|
||||
|
||||
;; Testing outer environment
|
||||
(def! a 4)
|
||||
|
@ -2,6 +2,8 @@
|
||||
|
||||
(def! sum2 (fn* (n acc) (if (= n 0) acc (sum2 (- n 1) (+ n acc)))))
|
||||
|
||||
;; TODO: test let*, and do for TCO
|
||||
|
||||
(sum2 10 0)
|
||||
;=>55
|
||||
|
||||
|
@ -223,24 +223,6 @@
|
||||
(count (keys (assoc hm2 "b" 2 "c" 3)))
|
||||
;=>3
|
||||
|
||||
(def! hm3 (assoc hm2 "b" 2))
|
||||
(count (keys hm3))
|
||||
;=>2
|
||||
(count (vals hm3))
|
||||
;=>2
|
||||
|
||||
(dissoc hm3 "a")
|
||||
;=>{"b" 2}
|
||||
|
||||
(dissoc hm3 "a" "b")
|
||||
;=>{}
|
||||
|
||||
(dissoc hm3 "a" "b" "c")
|
||||
;=>{}
|
||||
|
||||
(count (keys hm3))
|
||||
;=>2
|
||||
|
||||
;; Testing keywords as hash-map keys
|
||||
(get {:abc 123} :abc)
|
||||
;=>123
|
||||
@ -250,8 +232,6 @@
|
||||
;=>false
|
||||
(assoc {} :bcd 234)
|
||||
;=>{:bcd 234}
|
||||
(dissoc {:cde 345 :fgh 456} :cde)
|
||||
;=>{:fgh 456}
|
||||
(keyword? (nth (keys {:abc 123 :def 456}) 0))
|
||||
;=>true
|
||||
;;; TODO: support : in strings in make impl
|
||||
@ -265,30 +245,6 @@
|
||||
;=>true
|
||||
(assoc {} :bcd nil)
|
||||
;=>{:bcd nil}
|
||||
(dissoc {:cde nil :fgh 456} :cde)
|
||||
;=>{:fgh 456}
|
||||
|
||||
;; Testing equality of hash-maps
|
||||
(= {} {})
|
||||
;=>true
|
||||
(= {:a 11 :b 22} (hash-map :b 22 :a 11))
|
||||
;=>true
|
||||
(= {:a 11 :b [22 33]} (hash-map :b [22 33] :a 11))
|
||||
;=>true
|
||||
(= {:a 11 :b {:c 33}} (hash-map :b {:c 33} :a 11))
|
||||
;=>true
|
||||
(= {:a 11 :b 22} (hash-map :b 23 :a 11))
|
||||
;=>false
|
||||
(= {:a 11 :b 22} (hash-map :a 11))
|
||||
;=>false
|
||||
(= {:a [11 22]} {:a (list 11 22)})
|
||||
;=>true
|
||||
(= {:a 11 :b 22} (list :a 11 :b 22))
|
||||
;=>false
|
||||
(= {} [])
|
||||
;=>false
|
||||
(= [] {})
|
||||
;=>false
|
||||
|
||||
;;
|
||||
;; Additional str and pr-str tests
|
||||
@ -334,8 +290,53 @@
|
||||
;;;; "exc is:" ["data" "foo"] ;;;;=>7
|
||||
;;;;=>7
|
||||
|
||||
;;
|
||||
;; Testing throwing non-strings
|
||||
(try* (throw (list 1 2 3)) (catch* exc (do (prn "err:" exc) 7)))
|
||||
; "err:" (1 2 3)
|
||||
;=>7
|
||||
|
||||
;;
|
||||
;; Testing dissoc
|
||||
(def! hm3 (assoc hm2 "b" 2))
|
||||
(count (keys hm3))
|
||||
;=>2
|
||||
(count (vals hm3))
|
||||
;=>2
|
||||
(dissoc hm3 "a")
|
||||
;=>{"b" 2}
|
||||
(dissoc hm3 "a" "b")
|
||||
;=>{}
|
||||
(dissoc hm3 "a" "b" "c")
|
||||
;=>{}
|
||||
(count (keys hm3))
|
||||
;=>2
|
||||
|
||||
(dissoc {:cde 345 :fgh 456} :cde)
|
||||
;=>{:fgh 456}
|
||||
(dissoc {:cde nil :fgh 456} :cde)
|
||||
;=>{:fgh 456}
|
||||
|
||||
;;
|
||||
;; Testing equality of hash-maps
|
||||
(= {} {})
|
||||
;=>true
|
||||
(= {:a 11 :b 22} (hash-map :b 22 :a 11))
|
||||
;=>true
|
||||
(= {:a 11 :b [22 33]} (hash-map :b [22 33] :a 11))
|
||||
;=>true
|
||||
(= {:a 11 :b {:c 33}} (hash-map :b {:c 33} :a 11))
|
||||
;=>true
|
||||
(= {:a 11 :b 22} (hash-map :b 23 :a 11))
|
||||
;=>false
|
||||
(= {:a 11 :b 22} (hash-map :a 11))
|
||||
;=>false
|
||||
(= {:a [11 22]} {:a (list 11 22)})
|
||||
;=>true
|
||||
(= {:a 11 :b 22} (list :a 11 :b 22))
|
||||
;=>false
|
||||
(= {} [])
|
||||
;=>false
|
||||
(= [] {})
|
||||
;=>false
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user