diff --git a/.travis.yml b/.travis.yml index 382779ac78..5a8ec99517 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,6 +12,7 @@ matrix: - {env: IMPL=basic basic_MODE=cbm NO_SELF_HOST=1, services: [docker]} # step4 OOM - {env: IMPL=basic basic_MODE=qbasic NO_SELF_HOST=1, services: [docker]} # step4 OOM - {env: IMPL=bbc-basic, services: [docker]} + - {env: IMPL=bcpl, services: [docker]} - {env: IMPL=c, services: [docker]} - {env: IMPL=cpp, services: [docker]} - {env: IMPL=coffee, services: [docker]} diff --git a/Makefile b/Makefile index c42c5ca62f..18a546bf04 100644 --- a/Makefile +++ b/Makefile @@ -89,7 +89,7 @@ DOCKERIZE = # Implementation specific settings # -IMPLS = ada ada.2 awk bash basic bbc-basic c chuck clojure coffee common-lisp cpp crystal cs d dart \ +IMPLS = ada ada.2 awk bash basic bbc-basic bcpl c chuck clojure coffee common-lisp cpp crystal cs d dart \ elisp elixir elm erlang es6 factor fantom forth fsharp go groovy gnu-smalltalk \ guile haskell haxe hy io java js jq julia kotlin livescript logo lua make mal \ matlab miniMAL nasm nim objc objpascal ocaml perl perl6 php picolisp pike plpgsql \ @@ -191,6 +191,7 @@ awk_STEP_TO_PROG = impls/awk/$($(1)).awk bash_STEP_TO_PROG = impls/bash/$($(1)).sh basic_STEP_TO_PROG = $(basic_STEP_TO_PROG_$(basic_MODE)) bbc-basic_STEP_TO_PROG = impls/bbc-basic/$($(1)).bas +bcpl_STEP_TO_PROG = impls/bcpl/$($(1)) c_STEP_TO_PROG = impls/c/$($(1)) chuck_STEP_TO_PROG = impls/chuck/$($(1)).ck clojure_STEP_TO_PROG = $(clojure_STEP_TO_PROG_$(clojure_MODE)) diff --git a/impls/bcpl/Dockerfile b/impls/bcpl/Dockerfile new file mode 100644 index 0000000000..89bf588e6b --- /dev/null +++ b/impls/bcpl/Dockerfile @@ -0,0 +1,38 @@ +FROM ubuntu:18.04 +MAINTAINER Joel Martin + +########################################################## +# 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 +########################################################## + +RUN apt-get -y install gcc mesa-common-dev libglu1-mesa-dev freeglut3-dev + +RUN cd /usr/local && \ + curl -o bcpl.tgz https://www.cl.cam.ac.uk/~mr10/BCPL/bcpl.tgz && \ + tar zxf bcpl.tgz && chmod -R a+rX BCPL && rm bcpl.tgz + +ENV PATH /usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:\ +/usr/local/BCPL/cintcode/bin +ENV BCPLROOT /usr/local/BCPL/cintcode +ENV BCPLPATH /usr/local/BCPL/cintcode/cin +ENV BCPLHDRS /usr/local/BCPL/cintcode/g +ENV BCPLSCRIPTS /usr/local/BCPL/cintcode/s + +RUN cd /usr/local/BCPL/cintcode && make clean && make + diff --git a/impls/bcpl/Makefile b/impls/bcpl/Makefile new file mode 100644 index 0000000000..cb6ecdde85 --- /dev/null +++ b/impls/bcpl/Makefile @@ -0,0 +1,18 @@ +all: step0_repl step1_read_print step2_eval step3_env step4_if_fn_do \ + step5_tco step6_file step7_quote step8_macros step9_try stepA_mal + +%: %.b malhdr.h + cintsys -c "bcpl $< to $@" + +.DELETE_ON_ERROR: + +step0_repl: readline.b types.b +step1_read_print step2_eval: printer.b reader.b readline.b types.b +step3_env: env.b printer.b reader.b readline.b types.b +step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try \ + stepA_mal: \ + core.b env.b printer.b reader.b readline.b types.b + +clean: + rm -f step0_repl step1_read_print step2_eval step3_env step4_if_fn_do \ + step5_tco step6_file step7_quote step8_macros step9_try stepA_mal diff --git a/impls/bcpl/README.md b/impls/bcpl/README.md new file mode 100644 index 0000000000..5db3b16214 --- /dev/null +++ b/impls/bcpl/README.md @@ -0,0 +1,21 @@ +* Mal in BCPL + +This implementation expects to be built using the Cintcode BCPL +compiler. It may require modifications to work with other BCPL +compilers. + +It uses several features that are not mentioned, or are +described as extensions by _BCPL - the language and its compiler_, +including: + * The infixed byte operator `%` + * Using `{` and `}` as section brackets + * Using lower case and `_` in variable names + * Using `?` to indicate an uninitialised value + +BCPL does support separate compilation, but running +separately-compiled modules in Cintsys seems to be ill-supported, +requiring use of the run-time dynamic loading mechanism, `loadseg`. +The examples in the manual all use `GET` to textually include library +source code in the main program, so mal does the same. Nonetheless, +in an environment with separate compilation it should be possible to +remove all these `GET` directives and compile each `.b` file separately. \ No newline at end of file diff --git a/impls/bcpl/core.b b/impls/bcpl/core.b new file mode 100644 index 0000000000..01034b933a --- /dev/null +++ b/impls/bcpl/core.b @@ -0,0 +1,426 @@ +GET "libhdr" +GET "malhdr" + +// The Guide would have the file simply declare a data structure +// specifying the mal core namespace, with the step files constructing +// repl_env based on it. This is not really appropriate in BCPL, +// though. BCPL has almost no facilities for defining static data. +// There is TABLE, but that's restricted to compile-time constants. +// Pointers in BCPL are not compile-time constants, so a TABLE cannot +// contain any strings, or pointers to routines, or pointers to other +// TABLEs. This means that core.ns would have to be defined by +// a function constructing it, but if we are going to do that, we may +// as well have the function construct an entire environment instead. + +LET core_env() = VALOF +{ LET env = env_new(nil, empty, empty) + LET def(env, name, value) BE env_set(env, as_sym(str_bcpl2mal(name)), value) + LET bare_fun(fn) = alloc_fun(fn, fun_data) + + // A common form of core function is a wrapped function, where one + // function does the actual work while another (the wrapper) handles + // conversion between mal and BCPL conventions. The wrapper + // functions tend to be more complicated, but they can be shared + // between many wrapped functions. + MANIFEST { wf_wrapped = fun_data; wf_sz } + + // Arithmetic functions + { LET arith(fn, args) = VALOF + { LET a, b = args!lst_first, args!lst_rest!lst_first + UNLESS type OF a = type OF b = t_int DO + throwf("bad arguments for arithmetic function: %v", args) + RESULTIS alloc_int((fn!wf_wrapped)(a!int_value, b!int_value)) + } + LET arith_fun(fn) = alloc_fun(arith, wf_sz, fn) + + LET add(a, b) = a + b + LET sub(a, b) = a - b + LET mul(a, b) = a * b + LET div(a, b) = VALOF + { IF b = 0 THEN throwf("division by zero") + RESULTIS a / b + } + + def(env, "+", arith_fun(add)) + def(env, "-", arith_fun(sub)) + def(env, "**", arith_fun(mul)) + def(env, "/", arith_fun(div)) + } + + // Predicates + { LET pred(fn, args) = (fn!wf_wrapped)(args!lst_first) -> mtrue, mfalse + LET pred_fun(fn) = alloc_fun(pred, wf_sz, fn) + + LET listp(val) = type OF val = t_lst + // The '->' here is to make sure that | and & are in truth-value + // context. + LET emptyp(val) = val = + empty | supertype OF val = t_vec & val!vec_len = 0 -> TRUE, FALSE + LET atomp(val) = type OF val = t_atm + LET nilp(val) = val = nil + LET truep(val) = val = mtrue + LET falsep(val) = val = mfalse + LET numberp(val) = type OF val = t_int + LET stringp(val) = type OF val = t_str + LET symbolp(val) = type OF val = t_sym + LET keywordp(val) = type OF val = t_kwd + LET vectorp(val) = type OF val = t_vec + LET sequentialp(val) = type OF val = t_lst | type OF val = t_vec + LET mapp(val) = val = empty_hashmap | supertype OF val = t_hmi + LET macrop(val) = type OF val = t_mfn & mfn_ismacro OF val = 1 + LET fnp(val) = supertype OF val = t_fun & ~macrop(val) + + def(env, "list?", pred_fun(listp)) + def(env, "empty?", pred_fun(emptyp)) + def(env, "atom?", pred_fun(atomp)) + def(env, "nil?", pred_fun(nilp)) + def(env, "true?", pred_fun(truep)) + def(env, "false?", pred_fun(falsep)) + def(env, "number?", pred_fun(numberp)) + def(env, "string?", pred_fun(stringp)) + def(env, "symbol?", pred_fun(symbolp)) + def(env, "keyword?", pred_fun(keywordp)) + def(env, "vector?", pred_fun(vectorp)) + def(env, "sequential?", pred_fun(sequentialp)) + def(env, "map?", pred_fun(mapp)) + def(env, "fn?", pred_fun(fnp)) + def(env, "macro?", pred_fun(macrop)) + } + + // Comparisons + { LET equalp(fn, args) = VALOF + { LET a, b = args!lst_first, args!lst_rest!lst_first + RESULTIS equal(a, b) -> mtrue, mfalse + } + LET cmp(fn, args) = VALOF + { LET a, b = args!lst_first, args!lst_rest!lst_first + UNLESS type OF a = type OF b = t_int DO + throwf("bad arguments for arithmetic function: %v", args) + RESULTIS (fn!wf_wrapped)(a!int_value, b!int_value) -> mtrue, mfalse + } + LET cmp_fun(fn) = alloc_fun(cmp, wf_sz, fn) + + LET lt(a, b) = a < b + LET le(a, b) = a <= b + LET gt(a, b) = a > b + LET ge(a, b) = a >= b + + def(env, "=", bare_fun(equalp)) + def(env, "<", cmp_fun(lt)) + def(env, "<=", cmp_fun(le)) + def(env, ">", cmp_fun(gt)) + def(env, ">=", cmp_fun(ge)) + } + + // Miscellaneous list functions + { LET core_cons(fn, args) = + cons(args!lst_first, as_lst(args!lst_rest!lst_first)) + LET concat(fn, args) = VALOF + { LET head, tailp = empty, @head + IF args = empty RESULTIS empty + UNTIL args!lst_rest = empty DO + { LET this = as_lst(args!lst_first) + UNTIL this = empty DO + { !tailp := cons(this!lst_first, empty) + tailp := @(!tailp)!lst_rest + this := this!lst_rest + } + args := args!lst_rest + } + !tailp := as_lst(args!lst_first) + RESULTIS head + } + LET count(fn, args) = VALOF + { LET arg = args!lst_first + SWITCHON supertype OF arg INTO + { CASE t_nil: RESULTIS alloc_int(0) + CASE t_lst: + { LET n = 0 + UNTIL arg = empty DO n, arg := n + 1, arg!lst_rest + RESULTIS alloc_int(n) + } + CASE t_vec: RESULTIS alloc_int(arg!vec_len) + DEFAULT: throwf("invalid argument to count: %v", arg) + } + } + LET core_nth(fn, args) = VALOF + { LET seq, n = args!lst_first, args!lst_rest!lst_first + UNLESS type OF n = t_int DO throwf("subscript not an integer") + n := n!int_value + IF type OF seq = t_lst RESULTIS nth(seq, n) + IF type OF seq = t_vec THEN + { IF n >= seq!vec_len THEN throwf("subscript out of range") + RESULTIS (seq+vec_data)!n + } + throwf("nth applied to non-sequence") + } + LET first(fn, args) = VALOF + { LET seq = args!lst_first + IF type OF seq = t_vec & seq!vec_len > 0 RESULTIS seq!vec_data + RESULTIS as_lst(seq)!lst_first + } + LET rest(fn, args) = as_lst(args!lst_first)!lst_rest + LET conj(fn, args) = VALOF + { LET seq = args!lst_first + args := args!lst_rest + IF type OF seq = t_lst THEN + { UNTIL args = empty DO + seq, args := cons(args!lst_first, seq), args!lst_rest + RESULTIS seq + } + IF type OF seq = t_vec THEN + { LET vec = ? + LET n, ptr = seq!vec_len, args + UNTIL ptr = empty DO + n, ptr := n + 1, ptr!lst_rest + vec := alloc_vec(n) + FOR i = 0 TO seq!vec_len - 1 DO + (vec+vec_data)!i := (seq+vec_data)!i + FOR i = seq!vec_len TO n - 1 DO + (vec+vec_data)!i, args := args!lst_first, args!lst_rest + RESULTIS vec + } + throwf("conj applied to non-sequence") + } + LET seq(fn, args) = VALOF + { LET arg = args!lst_first + IF arg = empty | arg = nil RESULTIS nil + IF type OF arg = t_lst RESULTIS arg + IF type OF arg = t_vec RESULTIS arg!vec_len = 0 -> nil, as_lst(arg) + IF supertype OF arg = t_str THEN + { LET l = empty + IF arg!str_len = 0 RESULTIS nil + FOR i = arg!str_len TO 1 BY -1 DO + { LET s = alloc_str(1) + (s+str_data)%1 := (arg+str_data)%i + str_setlen(s, 1) + l := cons(s, l) + } + RESULTIS l + } + throwf("invalid argument to seq") + } + def(env, "cons", bare_fun(core_cons)) + def(env, "concat", bare_fun(concat)) + def(env, "count", bare_fun(count)) + def(env, "nth", bare_fun(core_nth)) + def(env, "first", bare_fun(first)) + def(env, "rest", bare_fun(rest)) + def(env, "conj", bare_fun(conj)) + def(env, "seq", bare_fun(seq)) + } + + // Reading function + { LET read_string(fn, args) = VALOF + { UNLESS type OF (args!lst_first) = t_str DO + throwf("invalid argument to read-string: %v", args!lst_first) + RESULTIS read_str(args!lst_first) + } + def(env, "read-string", bare_fun(read_string)) + } + + // Printing functions + { LET prstr(fn, args) = pr_multi(args, TRUE, TRUE) + LET str(fn, args) = pr_multi(args, FALSE, FALSE) + LET prn(fn, args) = VALOF + { writes(@(pr_multi(args, TRUE, TRUE)!str_data)) + newline() + RESULTIS nil + } + LET println(fn, args) = VALOF + { writes(@(pr_multi(args, FALSE, TRUE)!str_data)) + newline() + RESULTIS nil + } + def(env, "pr-str", bare_fun(prstr)) + def(env, "str", bare_fun(str)) + def(env, "prn", bare_fun(prn)) + def(env, "println", bare_fun(println)) + } + + // Input/output functions + { LET slurp(fn, args) = VALOF + { LET scb = ? + LET oldcis = cis + LET dest, dest_size, ptr = ?, 1024, 1 + UNLESS type OF (args!lst_first) = t_str DO + throwf("invalid argument to slurp: %v", args!lst_first) + scb := findinput(@(args!lst_first!str_data)) + IF scb = 0 THEN + throwf("couldn't open %v for input", args!lst_first) + // rdch() only reads from the current input stream, cis. + cis := scb + dest := alloc_str(dest_size) + { LET c = rdch() + IF c = endstreamch BREAK + IF ptr >= dest_size THEN + { LET tmp = ? + dest_size := dest_size * 2 + tmp := alloc_str(dest_size) + FOR i = 1 TO str_data + dest_size / bytesperword DO + tmp!i := dest!i + dest := tmp + } + (dest + str_data)%ptr := c + ptr := ptr + 1 + } REPEAT + str_setlen(dest, ptr - 1) + cis := oldcis + endstream(scb) + RESULTIS dest + } + LET core_readline(fn, args) = readline(as_str(args!lst_first)) + LET time_ms(fn, args) = VALOF + { LET datv = VEC 3 + datstamp(datv) + // On systems with big enough words, return milliseconds since epoch. + IF BITSPERBCPLWORD >= 44 THEN + RESULTIS alloc_int(datv!0 * 86400000 + datv!1) + // Otherwise, return millisends since start of day. + RESULTIS alloc_int(datv!1) + } + def(env, "slurp", bare_fun(slurp)) + def(env, "readline", bare_fun(core_readline)) + def(env, "time-ms", bare_fun(time_ms)) + } + + // Constructors + { LET list(fn, args) = args + LET str_conv(fn, args) = VALOF + { UNLESS supertype OF (args!lst_first) = t_str DO + throwf("Cannot treat %v as a string", args!lst_first) + RESULTIS (fn!wf_wrapped)(args!lst_first) + } + LET vector(fn, args) = VALOF + { LET vec = ? + LET ptr, n = args, 0 + UNTIL ptr = empty DO + n, ptr := n + 1, ptr!lst_rest + vec := alloc_vec(n) + FOR i = 0 TO n - 1 DO + (vec+vec_data)!i, args := args!lst_first, args!lst_rest + RESULTIS vec + } + def(env, "list", bare_fun(list)) + def(env, "symbol", alloc_fun(str_conv, wf_sz, as_sym)) + def(env, "keyword", alloc_fun(str_conv, wf_sz, as_kwd)) + def(env, "vector", bare_fun(vector)) + } + + // Hash-map functions + { LET as_hashmap(hm) = VALOF + { IF hm = nil THEN hm := empty_hashmap + UNLESS hm = empty_hashmap | supertype OF hm = t_hmi DO + throwf("Not a hash-map: %v", hm) + RESULTIS hm + } + LET assoc(fn, args) = VALOF + { LET hm = as_hashmap(args!lst_first) + args := args!lst_rest + UNTIL args = empty DO + { hm := hm_set(hm, args!lst_first, args!lst_rest!lst_first) + args := args!lst_rest!lst_rest + } + RESULTIS hm + } + LET hash_map(fn, args) = assoc(fn, cons(empty_hashmap, args)) + LET dissoc(fn, args) = VALOF + { LET hm = as_hashmap(args!lst_first) + args := args!lst_rest + UNTIL args = empty DO + hm, args := hm_remove(hm, args!lst_first), args!lst_rest + RESULTIS hm + } + LET get(fn, args) = + hm_get(as_hashmap(args!lst_first), args!lst_rest!lst_first) + LET containsp(fn, args) = + hm_contains(as_hashmap(args!lst_first), args!lst_rest!lst_first) -> + mtrue, mfalse + LET fields(fn, args, field) = VALOF + { LET hm = as_hashmap(args!lst_first) + LET fields1(hm, field, acc) = VALOF + { IF type OF hm = t_hmx RESULTIS cons(hm!field, acc) + acc := fields1(hm!hmi_right, field, acc) + RESULTIS fields1(hm!hmi_left, field, acc) + } + IF hm = empty_hashmap RESULTIS empty + RESULTIS fields1(hm, field, empty) + } + LET keys(fn, args) = fields(fn, args, hmx_key) + LET vals(fn, args) = fields(fn, args, hmx_value) + def(env, "hash-map", bare_fun(hash_map)) + def(env, "assoc", bare_fun(assoc)) + def(env, "dissoc", bare_fun(dissoc)) + def(env, "get", bare_fun(get)) + def(env, "contains?", bare_fun(containsp)) + def(env, "keys", bare_fun(keys)) + def(env, "vals", bare_fun(vals)) + } + + // Atom functions + { LET atom(fn, args) = alloc_atm(args!lst_first) + LET deref(fn, args) = VALOF + { UNLESS type OF (args!lst_first) = t_atm DO + throwf("invalid argument to deref: %v", args!lst_first) + RESULTIS args!lst_first!atm_value + } + LET reset(fn, args) = VALOF + { UNLESS type OF (args!lst_first) = t_atm DO + throwf("invalid argument to reset!: %v", args!lst_first) + args!lst_first!atm_value := args!lst_rest!lst_first + RESULTIS args!lst_rest!lst_first + } + LET swap(fn, args, gc_root) = VALOF + { LET atm, fn = args!lst_first, args!lst_rest!lst_first + LET gc_inner_root = cons(atm, gc_root) + UNLESS type OF atm = t_atm & supertype OF fn = t_fun DO + throwf("invalid arguments to swap!: %v", args) + atm!atm_value := + (fn!fun_code)(fn, cons(atm!atm_value, args!lst_rest!lst_rest), + gc_inner_root) + RESULTIS atm!atm_value + } + + def(env, "atom", bare_fun(atom)) + def(env, "deref", bare_fun(deref)) + def(env, "reset!", bare_fun(reset)) + def(env, "swap!", bare_fun(swap)) + } + + // Control-flow functions + { LET core_throw(fn, args) = throw(args!lst_first) + LET apply(fn, args, gc_root) = VALOF { + LET inner_fn, head, tailp = args!lst_first, empty, @head + args := args!lst_rest + UNTIL args!lst_rest = empty DO + { !tailp := cons(args!lst_first, empty) + tailp := @(!tailp)!lst_rest + args := args!lst_rest + } + !tailp := as_lst(args!lst_first) + RESULTIS (inner_fn!fun_code)(inner_fn, head, gc_root) + } + LET map(fn, args, gc_root) = VALOF + { LET inner_fn, seq = args!lst_first, as_lst(args!lst_rest!lst_first) + LET dummy_head, tail = cons(nil, empty), dummy_head + LET gc_inner_root = alloc_vecn(4, seq, dummy_head, inner_fn, gc_root) + UNTIL seq = empty DO + { tail!lst_rest := + cons((inner_fn!fun_code)(inner_fn, cons(seq!lst_first, nil), + gc_inner_root), empty) + tail, seq := tail!lst_rest, seq!lst_rest + } + RESULTIS dummy_head!lst_rest + } + def(env, "throw", bare_fun(core_throw)) + def(env, "apply", bare_fun(apply)) + def(env, "map", bare_fun(map)) + } + + // Unimplemented stubs + { LET not_implemented() BE throwf("not implemented") + def(env, "meta", bare_fun(not_implemented)) + def(env, "with-meta", bare_fun(not_implemented)) + } + RESULTIS env +} diff --git a/impls/bcpl/env.b b/impls/bcpl/env.b new file mode 100644 index 0000000000..0a6ed13719 --- /dev/null +++ b/impls/bcpl/env.b @@ -0,0 +1,33 @@ +GET "libhdr" +GET "malhdr" + +LET env_set(env, key, value) BE + env!env_data := hm_set(env!env_data, key, value) + +LET env_new(outer, binds, exprs) = VALOF +{ LET env = alloc_val(env_sz) + type OF env := t_env + env!env_outer := outer + env!env_data := empty_hashmap + UNTIL binds = empty DO + { IF str_eq_const(binds!lst_first, "&") THEN + { env_set(env, nth(binds, 1), exprs) + BREAK + } + env_set(env, binds!lst_first, exprs!lst_first) + binds, exprs := binds!lst_rest, exprs!lst_rest + } + RESULTIS env +} + +LET env_find(env, key) = VALOF +{ IF hm_contains(env!env_data, key) THEN RESULTIS env + UNLESS env!env_outer = nil RESULTIS env_find(env!env_outer, key) + RESULTIS nil +} + +LET env_get(env, key) = VALOF +{ env := env_find(env, key) + IF env = nil THEN throwf("'%v' not found", key) + RESULTIS hm_get(env!env_data, key) +} diff --git a/impls/bcpl/malhdr.h b/impls/bcpl/malhdr.h new file mode 100644 index 0000000000..c282d06d01 --- /dev/null +++ b/impls/bcpl/malhdr.h @@ -0,0 +1,92 @@ +GLOBAL { readline: ug + pr_str; pr_multi; throwf + read_str + init_types; nil; empty; empty_hashmap; mtrue; mfalse + gc + alloc_val + equal + cons; nth; as_lst + alloc_int + str_setlen; alloc_str; str_substr; str_bcpl2mal + as_str; as_sym; as_kwd; str_eq_const + hm_set; hm_contains; hm_remove; hm_get; hm_dump + alloc_vec; alloc_vecn + alloc_fun + alloc_atm + throw + env_new; env_set + catch_level; catch_label; last_exception + core_env +} + +MANIFEST +{ + // The first word of each value is a pointer to the next element + // of the global object list. + nextptr = 0 + + // The second word of any mal value indicates its type and suchlike. + // The "supertype" indicates the meaning of the other words of the + // value. The "type" distinguishes mal types with the same supertype + // (for instance functions and macros). The compoundflag is set on + // compund types (ones containing references to other values). + compoundflag = SLCT 1:3:1; supertype = SLCT 4:0:1; type = SLCT 8:0:1 + gc_marked = SLCT 1:8:1 + + // Nil. There is a single nil value initialised by init_types(), but + // it's a valid pointer so it can safely be dereferenced. + t_nil = #x00 + nil_sz = 2 + + // Lists. These are implemented as a linked list. The empty list, + // like nil, is a special value. + t_lst = #x08; lst_first = 2; lst_rest = 3; lst_sz = 4 + + // Integers. + t_int = #x01; int_value = 2; int_sz = 3 + + // Booleans. + t_boo = #x11 + + // Strings. Unlike conventional BCPL strings, these have an entire word + // to store the length. For compatibility with library routines, the + // first byte of the string is also the length if it will fit. + t_str = #x02; str_len = 2; str_data = 3 + + // Symbols and keywords. Like strings, but with different types. + t_sym = #x12 + t_kwd = #x22 + + maxbcplstrlen = (1 << (BITSPERBCPLWORD / bytesperword)) - 1 + + // Environments. While technically these don't have to be a mal type, + // it makes the garbage collector simpler if they are. + t_env = #x0e; env_outer = 2; env_data = 3; env_sz = 4 + + // Vectors. Structured like strings except that the data consists of + // pointers rather than packed characters. + t_vec = #x09; vec_len = 2; vec_data = 3 + + // Functions. Contains a function which gets passed a pointer to + // this structure and can do what it likes with it. fun_ntracked + // is the number of tracked pointers at the start of fun_data. + t_fun = #x0f; fun_code = 2; fun_data = 3 + fun_ntracked = SLCT 2:9:1 + + // Functions defined in mal. These are returned by fn* and are + // handled specially by the tail-call optimisation in EVAL. + t_mfn = #x1f + mfn_ismacro = SLCT 1:11:1 + + // Hash-maps. These are implemented as crit-bit trees. There are three + // types of node: internal nodes point to two other nodes and encode a + // bit offset in the spare bits of the first word. External nodes + // point to a key and a value. Empty nodes describe an empty hash-map. + t_hmi = #x0b; hmi_left = 2; hmi_right = 3; hmi_sz = 4 + hmi_critbit = SLCT 0:9:1; hmi_maxcritbit = (1 << BITSPERBCPLWORD - 9) - 1 + t_hmx = #x1b; hmx_key = 2; hmx_value = 3; hmx_sz = 4 + t_hm0 = #x0c; hm0_sz = 2 + + // Atoms. + t_atm = #x0a; atm_value = 2; atm_sz = 3 +} diff --git a/impls/bcpl/printer.b b/impls/bcpl/printer.b new file mode 100644 index 0000000000..8ac7518868 --- /dev/null +++ b/impls/bcpl/printer.b @@ -0,0 +1,193 @@ +GET "libhdr" +GET "malhdr" + +// The general structure of printing routines is: +// print_thing(..., buf, pos, count_only) +// buf is a buffer accumulating the output (only if count_only is FALSE) +// pos is the output offset within that buffer +// if count_only is FALSE, then routine will write result to buf +// in any case, pos is new output offset. + +MANIFEST { pc_pos = 0; pc_buf; pc_count_only; pc_print_readably; pc_sz } + +// Print a BCPL-format (constant) string. +LET print_const(pc, str) BE +{ UNLESS pc!pc_count_only DO + FOR i = 1 TO str%0 DO + pc!pc_buf%(pc!pc_pos + i - 1) := str%i + pc!pc_pos := pc!pc_pos + str%0 +} + +// Print a single character +LET print_char(pc, chr) BE +{ UNLESS pc!pc_count_only DO pc!pc_buf%(pc!pc_pos) := chr + pc!pc_pos := pc!pc_pos + 1 +} + +// Print a mal integer +LET print_int(pc, int) BE +{ LET val = int!int_value + LET len, negative = 0, FALSE + IF val = 0 THEN { print_char(pc, '0'); RETURN } + IF val < 0 THEN + { val := -val // XXX This doesnt work for the most negative integer + len := len + 1 + negative := TRUE + } + WHILE val > 0 DO + { val := val / 10 + len := len + 1 + } + IF pc!pc_count_only THEN { pc!pc_pos := pc!pc_pos + len; RETURN } + val := negative -> -int!int_value, int!int_value + pc!pc_pos := pc!pc_pos + len - 1 + WHILE val > 0 DO + { pc!pc_buf%(pc!pc_pos) := + (TABLE '0', '1', '2', '3', '4', '5', '6', '7', '8', '9')!(val REM 10) + val := val / 10 + pc!pc_pos := pc!pc_pos - 1 + } + IF negative THEN + { pc!pc_buf%(pc!pc_pos) := '-' + pc!pc_pos := pc!pc_pos - 1 + } + pc!pc_pos := pc!pc_pos + len + 1 +} + +// Print a mal string +LET print_str(pc, str) BE +{ print_char(pc, '*"') + FOR i = 1 TO str!str_len DO + { LET ch = (str + str_data)%i + SWITCHON ch INTO + { CASE '*n': ch := 'n' + CASE '\': CASE '*"': print_char(pc, '\') + } + print_char(pc, ch) + } + print_char(pc, '*"') +} + +LET print_sym(pc, sym) BE +{ UNLESS pc!pc_count_only DO + FOR i = 1 TO sym!str_len DO + pc!pc_buf%(pc!pc_pos + i - 1) := (sym + str_data)%i + pc!pc_pos := pc!pc_pos + sym!str_len +} + +LET print_kwd(pc, kwd) BE +{ print_char(pc, ':') + print_sym(pc, kwd) +} + +LET print_lst(pc, lst) BE +{ print_char(pc, '(') + UNLESS lst = empty DO + { print_form(pc, lst!lst_first) + lst := lst!lst_rest + IF lst = empty BREAK + print_char(pc, ' ') + } REPEAT + print_char(pc, ')') +} + +AND print_vec(pc, vec) BE +{ print_char(pc, '[') + FOR i = vec_data TO vec_data + vec!vec_len - 1 DO + { UNLESS i = vec_data DO print_char(pc, ' ') + print_form(pc, vec!i) + } + print_char(pc, ']') +} + +AND print_hmx_contents(pc, map) BE +{ print_form(pc, map!hmx_key) + print_char(pc, ' ') + print_form(pc, map!hmx_value) +} + +AND print_hmi_contents(pc, map) BE +{ print_hm_contents(pc, map!hmi_left) + print_char(pc, ' ') + print_hm_contents(pc, map!hmi_right) +} + +AND print_hm_contents(pc, map) BE + TEST type OF map = t_hmi THEN print_hmi_contents(pc, map) + ELSE print_hmx_contents(pc, map) + +AND print_hm(pc, map) BE +{ print_char(pc, '{') + print_hm_contents(pc, map) + print_char(pc, '}') +} + +AND print_atm(pc, atm) BE +{ print_const(pc, "(atom ") + print_form(pc, atm!atm_value) + print_char(pc, ')') +} + +AND print_form(pc, val) BE + SWITCHON type OF val INTO + { + CASE t_nil: print_const(pc, "nil"); ENDCASE + CASE t_boo: print_const(pc, val!int_value -> "true", "false"); ENDCASE + CASE t_lst: print_lst(pc, val); ENDCASE + CASE t_vec: print_vec(pc, val); ENDCASE + CASE t_hm0: print_const(pc, "{}"); ENDCASE + CASE t_hmi: + CASE t_hmx: print_hm (pc, val); ENDCASE + CASE t_int: print_int(pc, val); ENDCASE + CASE t_str: IF pc!pc_print_readably THEN { print_str(pc, val); ENDCASE } + CASE t_sym: print_sym(pc, val); ENDCASE + CASE t_kwd: print_kwd(pc, val); ENDCASE + CASE t_fun: + CASE t_mfn: print_const(pc, "#"); ENDCASE + CASE t_atm: print_atm(pc, val); ENDCASE + DEFAULT: print_const(pc, ""); ENDCASE + } + +LET print_multi(pc, lst, space) BE +{ UNLESS lst = empty DO + { print_form(pc, lst!lst_first) + lst := lst!lst_rest + IF lst = empty BREAK + IF space THEN print_char(pc, ' ') + } REPEAT +} + +LET pr(printer, x, print_readably, A) = VALOF +{ LET pc = VEC pc_sz + LET out = ? + pc!pc_pos := 0 + pc!pc_count_only := TRUE + pc!pc_print_readably := print_readably + printer(pc, x, A) + + out := alloc_str(pc!pc_pos) + pc!pc_buf := out + str_data + pc!pc_pos := 1 + pc!pc_count_only := FALSE + printer(pc, x, A) + str_setlen(out, pc!pc_pos - 1) + RESULTIS out +} + +LET pr_str(x) = pr(print_form, x, TRUE) + +LET pr_multi(x, print_readably, space) = + pr(print_multi, x, print_readably, space) + +LET print_f(pc, msg, A) BE +{ FOR i = 1 TO msg%0 DO + { IF msg%i = '%' & i < msg%0 THEN SWITCHON msg%(i + 1) INTO + { CASE 'v': + print_form(pc, A) + i := i + 1; LOOP + } + print_char(pc, msg%i) + } +} + +LET throwf(msg, A) BE throw(pr(print_f, msg, FALSE, A)) diff --git a/impls/bcpl/reader.b b/impls/bcpl/reader.b new file mode 100644 index 0000000000..03b0960cd6 --- /dev/null +++ b/impls/bcpl/reader.b @@ -0,0 +1,211 @@ +GET "libhdr" +GET "malhdr" + +// A Reader is just a pointer to a (variable) pointer to the head of +// a list of strings. + +LET reader_peek(rdr) = (!rdr)!lst_first + +LET reader_next(rdr) = VALOF +{ LET tok = reader_peek(rdr) + !rdr := (!rdr)!lst_rest + RESULTIS tok +} + +LET tokenize(s) = VALOF +{ LET tokens, tailp = empty, @tokens + LET sd = s + str_data + LET tokstart, token = ?, ? + FOR p = 1 TO s!str_len DO + { tokstart := p + // Within this SWITCHON command, use LOOP to ignore input, or ENDCASE to + // emit a token. + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': CASE ',': LOOP // Inter-token whitespace + CASE '~': // Maybe ~@ + IF p < s!str_len & sd%(p+1) = '@' THEN p := p + 1 // FALLTHROUGH + CASE '[': CASE ']': CASE '{': CASE '}': CASE '(': CASE ')': CASE '*'': + CASE '`': CASE '^': CASE '@': // Single-character token + ENDCASE + CASE ';': // Comment + p := p + 1 REPEATUNTIL p > s!str_len | sd%p = '*n' + LOOP + CASE '*"': // String + p := p + (sd%p = '\' -> 2, 1) REPEATUNTIL p > s!str_len | sd%p = '*"' + ENDCASE + DEFAULT: // Symbol, keyword, or number + WHILE p < s!str_len DO + { p := p + 1 + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': CASE ',': + CASE '[': CASE ']': CASE '{': CASE '}': CASE '(': CASE ')': + CASE '*'': CASE '`': CASE '~': CASE '^': CASE '@': CASE '*"': + CASE ';': + p := p - 1; BREAK + } + } + ENDCASE + } + // At this point, tokstart points to the first character of the token, + // and p points to the last character. + token := str_substr(s, tokstart, p + 1) + !tailp := cons(token, empty) + tailp := @(!tailp)!lst_rest + } + RESULTIS tokens +} + +// This is for reading into a string, as opposed to read_str, which is +// for reading from a string. +LET read_string(token) = VALOF +{ LET i, o, out = 2, 0, ? + WHILE i < token!str_len DO + { IF (token + str_data)%i = '\' THEN i := i + 1 + i, o := i + 1, o + 1 + } + UNLESS i = token!str_len & (token + str_data)%i = '*"' DO + throw(str_bcpl2mal("unbalanced quotes")) + out := alloc_str(o) + i, o := 2, 1 + WHILE i < token!str_len DO + { LET ch = (token + str_data)%i + IF ch = '\' THEN + { i := i + 1 + ch := (token + str_data)%i + IF ch = 'n' THEN ch := '*n' + } + (out + str_data)%o := ch + i, o := i + 1, o + 1 + } + str_setlen(out, o - 1) + RESULTIS out +} + +LET read_keyword(token) = as_kwd(str_substr(token, 2, token!str_len + 1)) + +LET read_number_maybe(token) = VALOF +{ LET sd, start, negative, acc = token + str_data, 1, FALSE, 0 + IF sd%1 = '-' THEN + { IF token!str_len = 1 THEN RESULTIS nil + negative := TRUE + start := 2 + } + FOR i = start TO token!str_len DO + { acc := acc * 10 + SWITCHON sd%i INTO + { CASE '0': ENDCASE + CASE '1': acc := acc + 1; ENDCASE + CASE '2': acc := acc + 2; ENDCASE + CASE '3': acc := acc + 3; ENDCASE + CASE '4': acc := acc + 4; ENDCASE + CASE '5': acc := acc + 5; ENDCASE + CASE '6': acc := acc + 6; ENDCASE + CASE '7': acc := acc + 7; ENDCASE + CASE '8': acc := acc + 8; ENDCASE + CASE '9': acc := acc + 9; ENDCASE + DEFAULT: RESULTIS nil + } + } + IF negative THEN acc := -acc + RESULTIS alloc_int(acc) +} + +LET read_atom(rdr) = VALOF +{ LET token, maybenum = reader_next(rdr), ? + IF (token + str_data)%1 = '*"' THEN RESULTIS read_string(token) + IF (token + str_data)%1 = ':' THEN RESULTIS read_keyword(token) + maybenum := read_number_maybe(token) + UNLESS maybenum = nil RESULTIS maybenum + IF str_eq_const(token, "nil") RESULTIS nil + IF str_eq_const(token, "true") RESULTIS mtrue + IF str_eq_const(token, "false") RESULTIS mfalse + RESULTIS as_sym(token) +} + +LET read_list(rdr) = VALOF +{ reader_next(rdr) // Skip leading '(' + RESULTIS read_list_tail(rdr) +} + +AND read_list_tail(rdr) = VALOF + TEST (reader_peek(rdr) + str_data)%1 = ')' THEN + { reader_next(rdr) + RESULTIS empty + } ELSE { + LET first = read_form(rdr) + LET rest = read_list_tail(rdr) + RESULTIS cons(first, rest) + } + +AND read_vec(rdr) = VALOF +{ reader_next(rdr) // Skip leading '[' + RESULTIS read_vec_tail(rdr, 0) +} + +AND read_vec_tail(rdr, len) = VALOF + TEST (reader_peek(rdr) + str_data)%1 = ']' THEN + { reader_next(rdr) + RESULTIS alloc_vec(len) + } ELSE { + LET first = read_form(rdr) + LET vec = read_vec_tail(rdr, len + 1) + (vec + vec_data)!len := first + RESULTIS vec + } + +AND read_hm(rdr) = VALOF +{ LET map = empty_hashmap + reader_next(rdr) // Skip leading '{' + { LET key, value = ?, ? + IF (reader_peek(rdr) + str_data)%1 = '}' THEN { reader_next(rdr); BREAK } + key := read_form(rdr) + IF (reader_peek(rdr) + str_data)%1 = '}' THEN + throw(str_bcpl2mal("odd number of elements in literal hash-map")) + value := read_form(rdr) + map := hm_set(map, key, value) + } REPEAT + RESULTIS map +} + +AND read_macro(rdr, name) = VALOF +{ LET first, rest = as_sym(str_bcpl2mal(name)), ? + reader_next(rdr) // skip macro character + rest := cons(read_form(rdr), empty) + RESULTIS cons(first, rest) +} + +AND read_with_meta(rdr) = VALOF +{ LET rest = ? + reader_next(rdr) // skip '^' + rest := cons(read_form(rdr), empty) + rest := cons(read_form(rdr), rest) + RESULTIS cons(as_sym(str_bcpl2mal("with-meta")), rest) +} + +AND read_form(rdr) = VALOF +{ LET token = reader_peek(rdr) + UNLESS type OF token = t_str DO + throw(str_bcpl2mal("unexpected end of input")) + SWITCHON (token + str_data)%1 INTO + { CASE '(': RESULTIS read_list(rdr) + CASE ')': throw(str_bcpl2mal("unbalanced parentheses")) + CASE '[': RESULTIS read_vec(rdr) + CASE ']': throw(str_bcpl2mal("unbalanced brackets")) + CASE '{': RESULTIS read_hm(rdr) + CASE '}': throw(str_bcpl2mal("unbalanced braces")) + CASE '*'': RESULTIS read_macro(rdr, "quote") + CASE '`': RESULTIS read_macro(rdr, "quasiquote") + CASE '~': + IF token!str_len = 2 THEN RESULTIS read_macro(rdr, "splice-unquote") + RESULTIS read_macro(rdr, "unquote") + CASE '@': RESULTIS read_macro(rdr, "deref") + CASE '^': RESULTIS read_with_meta(rdr) + DEFAULT: RESULTIS read_atom(rdr) + } +} + +LET read_str(s) = VALOF +{ LET tokens = tokenize(s) + LET rdr = @tokens + RESULTIS read_form(rdr) +} diff --git a/impls/bcpl/readline.b b/impls/bcpl/readline.b new file mode 100644 index 0000000000..135556294b --- /dev/null +++ b/impls/bcpl/readline.b @@ -0,0 +1,31 @@ +GET "libhdr" +GET "malhdr" + +MANIFEST +{ buflen = (1 << bitsperbyte) - 1 } + +// readline returns a newly-allocated mal string. +// 'prompt' is a mal string, +LET readline(prompt) = VALOF +{ LET dest, dest_size, ptr = ?, 1024, 1 + LET ch = 0 + writes(@prompt!str_data) + deplete(cos) + dest := alloc_str(dest_size) + { LET c = rdch() + IF c = endstreamch RESULTIS nil + IF c = '*n' BREAK + IF ptr >= dest_size THEN + { LET tmp = ? + dest_size := dest_size * 2 + tmp := alloc_str(dest_size) + FOR i = 1 TO str_data + dest_size / bytesperword DO + tmp!i := dest!i + dest := tmp + } + (dest + str_data)%ptr := c + ptr := ptr + 1 + } REPEAT + str_setlen(dest, ptr - 1) + RESULTIS dest +} diff --git a/impls/bcpl/run b/impls/bcpl/run new file mode 100755 index 0000000000..08a4f4911f --- /dev/null +++ b/impls/bcpl/run @@ -0,0 +1,2 @@ +#!/bin/bash +exec cintsys -- "$(dirname $0)/${STEP:-stepA_mal}" "${@}" diff --git a/impls/bcpl/step0_repl.b b/impls/bcpl/step0_repl.b new file mode 100644 index 0000000000..95e58d5e23 --- /dev/null +++ b/impls/bcpl/step0_repl.b @@ -0,0 +1,34 @@ +GET "libhdr" +GET "malhdr" + +GET "readline.b" +GET "types.b" + +LET READ(x) = x + +LET EVAL(x) = x + +LET PRINT(x) = x + +LET rep(x) = PRINT(EVAL(READ(x))) + +LET repl() BE +{ LET prompt = str_bcpl2mal("user> ") + { LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + } REPEAT +} + +LET start() = VALOF +{ LET ch = 0 + init_types() + ch := rdch() REPEATUNTIL ch = '*n' // Consume command-line args + wrch('*n') // Terminate prompt printed by Cintsys + repl() + RESULTIS 0 +} + +// Dummy version of throwf() because step 0 doesn't include printer.b +LET throwf(msg, A) BE throw(str_bcpl2mal(msg)) diff --git a/impls/bcpl/step1_read_print.b b/impls/bcpl/step1_read_print.b new file mode 100644 index 0000000000..e35c207618 --- /dev/null +++ b/impls/bcpl/step1_read_print.b @@ -0,0 +1,41 @@ +GET "libhdr" +GET "malhdr" + +GET "printer.b" +GET "reader.b" +GET "readline.b" +GET "types.b" + +LET READ(x) = read_str(x) + +LET EVAL(x) = x + +LET PRINT(x) = pr_str(x) + +LET rep(x) = PRINT(EVAL(READ(x))) + +LET repl() BE +{ catch_level, catch_label := level(), uncaught + IF FALSE THEN + { uncaught: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + } + { LET prompt = str_bcpl2mal("user> ") + LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + gc(nil) + } REPEAT +} + +LET start() = VALOF +{ LET ch = 0 + init_types() + ch := rdch() REPEATUNTIL ch = '*n' // Consume command-line args + wrch('*n') // Terminate prompt printed by Cintsys + repl() + RESULTIS 0 +} diff --git a/impls/bcpl/step2_eval.b b/impls/bcpl/step2_eval.b new file mode 100644 index 0000000000..dd6dd08176 --- /dev/null +++ b/impls/bcpl/step2_eval.b @@ -0,0 +1,106 @@ +GET "libhdr" +GET "malhdr" + +GET "printer.b" +GET "reader.b" +GET "readline.b" +GET "types.b" + +LET READ(x) = read_str(x) + +LET eval_ast(ast, env) = VALOF + SWITCHON type OF ast INTO + { CASE t_sym: + { LET result = hm_get(env, ast) + IF result = nil THEN throw(str_bcpl2mal("unknown function")) + RESULTIS result + } + CASE t_lst: + TEST ast = empty THEN RESULTIS empty + ELSE RESULTIS cons(EVAL(ast!lst_first, env), eval_ast(ast!lst_rest, env)) + CASE t_vec: + { LET new = alloc_vec(ast!vec_len) + FOR i = 0 TO ast!vec_len - 1 DO + (new + vec_data)!i := EVAL((ast + vec_data)!i, env) + RESULTIS new + } + CASE t_hmx: + RESULTIS alloc_hmx(ast!hmx_key, EVAL(ast!hmx_value, env)) + CASE t_hmi: + RESULTIS alloc_hmi(hmi_critbit OF ast, eval_ast(ast!hmi_left, env), + eval_ast(ast!hmi_right, env)) + DEFAULT: RESULTIS ast + } + +AND EVAL(ast, env) = VALOF +{ UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env) + IF ast = empty RESULTIS ast + ast := eval_ast(ast, env) + { LET fn, args = ast!lst_first, ast!lst_rest + UNLESS type OF fn = t_fun DO throwf("not a function") + RESULTIS (fn!fun_code)(fn, args) + } +} + +LET PRINT(x) = pr_str(x) + +STATIC { add_fun; sub_fun; mul_fun; div_fun; repl_env } + +LET init_core() BE +{ MANIFEST { wf_wrapped = fun_data; wf_sz = fun_data + 1 } + LET arith(fn, args) = VALOF + { LET a, b = args!lst_first, args!lst_rest!lst_first + UNLESS type OF a = type OF b = t_int DO + throwf("bad arguments for arithmetic function: %v", args) + RESULTIS alloc_int((fn!wf_wrapped)(a!int_value, b!int_value)) + } + LET arith_fun(fn) = alloc_fun(arith, wf_sz, fn) + + LET add(a, b) = a + b + LET sub(a, b) = a - b + LET mul(a, b) = a * b + LET div(a, b) = VALOF + { IF b = 0 THEN throwf("division by zero") + RESULTIS a / b + } + add_fun := arith_fun(add) + sub_fun := arith_fun(sub) + mul_fun := arith_fun(mul) + div_fun := arith_fun(div) +} + +LET rep(x) = PRINT(EVAL(READ(x), repl_env)) + +LET repl() BE +{ LET def(name, value) BE + repl_env := hm_set(repl_env, as_sym(str_bcpl2mal(name)), value) + repl_env := empty_hashmap + def("+", add_fun) + def("-", sub_fun) + def("**", mul_fun) + def("/", div_fun) + catch_level, catch_label := level(), uncaught + IF FALSE THEN + { uncaught: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + } + { LET prompt = str_bcpl2mal("user> ") + LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + gc(repl_env) + } REPEAT +} + +LET start() = VALOF +{ LET ch = 0 + init_types() + init_core() + ch := rdch() REPEATUNTIL ch = '*n' // Consume command-line args + wrch('*n') // Terminate prompt printed by Cintsys + repl() + RESULTIS 0 +} diff --git a/impls/bcpl/step3_env.b b/impls/bcpl/step3_env.b new file mode 100644 index 0000000000..88bf42462f --- /dev/null +++ b/impls/bcpl/step3_env.b @@ -0,0 +1,123 @@ +GET "libhdr" +GET "malhdr" + +GET "env.b" +GET "printer.b" +GET "reader.b" +GET "readline.b" +GET "types.b" + +LET READ(x) = read_str(x) + +// Helper function for EVAL. +LET is_sym(a, b) = VALOF +{ UNLESS type OF a = t_sym RESULTIS FALSE + RESULTIS str_eq_const(a, b) +} + +LET eval_ast(ast, env) = VALOF + SWITCHON type OF ast INTO + { CASE t_sym: RESULTIS env_get(env, ast) + CASE t_lst: + TEST ast = empty THEN RESULTIS empty + ELSE RESULTIS cons(EVAL(ast!lst_first, env), eval_ast(ast!lst_rest, env)) + CASE t_vec: + { LET new = alloc_vec(ast!vec_len) + FOR i = 0 TO ast!vec_len - 1 DO + (new + vec_data)!i := EVAL((ast + vec_data)!i, env) + RESULTIS new + } + CASE t_hmx: + RESULTIS alloc_hmx(ast!hmx_key, EVAL(ast!hmx_value, env)) + CASE t_hmi: + RESULTIS alloc_hmi(hmi_critbit OF ast, eval_ast(ast!hmi_left, env), + eval_ast(ast!hmi_right, env)) + DEFAULT: RESULTIS ast + } + +AND EVAL(ast, env) = VALOF +{ UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env) + IF ast = empty RESULTIS ast + { LET fn = ast!lst_first + IF is_sym(fn, "def!") THEN + { LET val = EVAL(nth(ast, 2), env) + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "let**") THEN + { LET newenv, bindings = env_new(env, empty, empty), as_lst(nth(ast, 1)) + UNTIL bindings = empty DO + { env_set(newenv, bindings!lst_first, EVAL(nth(bindings, 1), newenv)) + bindings := bindings!lst_rest!lst_rest + } + RESULTIS EVAL(nth(ast, 2), newenv) + } + } + ast := eval_ast(ast, env) + { LET fn, args = ast!lst_first, ast!lst_rest + UNLESS type OF fn = t_fun DO throwf("not a function") + RESULTIS (fn!fun_code)(fn, args) + } +} + +LET PRINT(x) = pr_str(x) + +STATIC { add_fun; sub_fun; mul_fun; div_fun; repl_env } + +LET init_core() BE +{ MANIFEST { wf_wrapped = fun_data; wf_sz = fun_data + 1 } + LET arith(fn, args) = VALOF + { LET a, b = args!lst_first, args!lst_rest!lst_first + UNLESS type OF a = type OF b = t_int DO + throwf("bad arguments for arithmetic function: %v", args) + RESULTIS alloc_int((fn!wf_wrapped)(a!int_value, b!int_value)) + } + LET arith_fun(fn) = alloc_fun(arith, wf_sz, fn) + + LET add(a, b) = a + b + LET sub(a, b) = a - b + LET mul(a, b) = a * b + LET div(a, b) = VALOF + { IF b = 0 THEN throwf("division by zero") + RESULTIS a / b + } + add_fun := arith_fun(add) + sub_fun := arith_fun(sub) + mul_fun := arith_fun(mul) + div_fun := arith_fun(div) +} + +LET rep(x) = PRINT(EVAL(READ(x), repl_env)) + +LET repl() BE +{ LET def(name, value) BE env_set(repl_env, as_sym(str_bcpl2mal(name)), value) + repl_env := env_new(nil, empty, empty) + def("+", add_fun) + def("-", sub_fun) + def("**", mul_fun) + def("/", div_fun) + catch_level, catch_label := level(), uncaught + IF FALSE THEN + { uncaught: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + } + { LET prompt = str_bcpl2mal("user> ") + LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + gc(repl_env) + } REPEAT +} + +LET start() = VALOF +{ LET ch = 0 + init_types() + init_core() + ch := rdch() REPEATUNTIL ch = '*n' // Consume command-line args + wrch('*n') // Terminate prompt printed by Cintsys + repl() + RESULTIS 0 +} diff --git a/impls/bcpl/step4_if_fn_do.b b/impls/bcpl/step4_if_fn_do.b new file mode 100644 index 0000000000..73d093ad97 --- /dev/null +++ b/impls/bcpl/step4_if_fn_do.b @@ -0,0 +1,132 @@ +GET "libhdr" +GET "malhdr" + +GET "core.b" +GET "env.b" +GET "printer.b" +GET "reader.b" +GET "readline.b" +GET "types.b" + +LET READ(x) = read_str(x) + +// Helper function for EVAL. +LET is_sym(a, b) = VALOF +{ UNLESS type OF a = t_sym RESULTIS FALSE + RESULTIS str_eq_const(a, b) +} + +LET eval_ast(ast, env, gc_root) = VALOF + SWITCHON type OF ast INTO + { CASE t_sym: RESULTIS env_get(env, ast) + CASE t_lst: + TEST ast = empty THEN RESULTIS empty + ELSE + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET first = EVAL(ast!lst_first, env, gc_inner_root) + LET rest = eval_ast(ast!lst_rest, env, cons(first, gc_root)) + RESULTIS cons(first, rest) + } + CASE t_vec: + { LET new = alloc_vec(ast!vec_len) + LET gc_inner_root = alloc_vecn(4, new, ast, env, gc_root) + FOR i = 0 TO ast!vec_len - 1 DO + (new + vec_data)!i := EVAL((ast + vec_data)!i, env, gc_inner_root) + RESULTIS new + } + CASE t_hmx: + { LET gc_inner_root = cons(ast, gc_root) + RESULTIS alloc_hmx(ast!hmx_key, EVAL(ast!hmx_value, env, gc_inner_root)) + } + CASE t_hmi: + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET left = eval_ast(ast!hmi_left, env, gc_inner_root) + LET right = eval_ast(ast!hmi_right, env, cons(left, gc_inner_root)) + RESULTIS alloc_hmi(hmi_critbit OF ast, left, right) + } + DEFAULT: RESULTIS ast + } + +AND EVAL(ast, env, gc_root) = VALOF +{ LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + gc(gc_inner_root) + UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env, gc_root) + IF ast = empty RESULTIS ast + { LET fn = ast!lst_first + IF is_sym(fn, "def!") THEN + { LET val = EVAL(nth(ast, 2), env, gc_inner_root) + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "let**") THEN + { LET newenv, bindings = env_new(env, empty, empty), as_lst(nth(ast, 1)) + gc_inner_root := alloc_vecn(3, newenv, bindings, gc_inner_root) + UNTIL bindings = empty DO + { env_set(newenv, bindings!lst_first, + EVAL(nth(bindings, 1), newenv, gc_inner_root)) + bindings := bindings!lst_rest!lst_rest + } + RESULTIS EVAL(nth(ast, 2), newenv, gc_root) + } + IF is_sym(fn, "do") THEN + { LET tail = ast!lst_rest + tail := eval_ast(tail, env, gc_root) + UNTIL tail!lst_rest = empty DO tail := tail!lst_rest + RESULTIS tail!lst_first + } + IF is_sym(fn, "if") THEN + { LET cond = EVAL(nth(ast, 1), env, gc_inner_root) + LET tail = ast!lst_rest!lst_rest + IF cond = nil | cond = mfalse THEN tail := tail!lst_rest + RESULTIS EVAL(tail!lst_first, env, gc_root) + } + IF is_sym(fn, "fn**") THEN + { MANIFEST { fun_binds = fun_data; fun_body; fun_env; fun_sz } + LET call(fun, args, gc_root) = + EVAL(fun!fun_body, env_new(fun!fun_env, fun!fun_binds, args), gc_root) + LET result = alloc_fun(call, fun_sz, + as_lst(nth(ast, 1)), nth(ast, 2), env) + fun_ntracked OF result := 3 + RESULTIS result + } + } + ast := eval_ast(ast, env, gc_root) + { LET fn, args = ast!lst_first, ast!lst_rest + UNLESS type OF fn = t_fun DO throwf("not a function") + RESULTIS (fn!fun_code)(fn, args, gc_root) + } +} + +LET PRINT(x) = pr_str(x) + +STATIC { repl_env } + +LET rep(x) = PRINT(EVAL(READ(x), repl_env, nil)) + +LET repl() BE +{ repl_env := core_env() + rep(str_bcpl2mal("(def! not (fn** (a) (if a false true)))")) + catch_level, catch_label := level(), uncaught + IF FALSE THEN + { uncaught: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + } + { LET prompt = str_bcpl2mal("user> ") + LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + gc(repl_env) + } REPEAT +} + +LET start() = VALOF +{ LET ch = 0 + init_types() + ch := rdch() REPEATUNTIL ch = '*n' // Consume command-line args + wrch('*n') // Terminate prompt printed by Cintsys + repl() + RESULTIS 0 +} diff --git a/impls/bcpl/step5_tco.b b/impls/bcpl/step5_tco.b new file mode 100644 index 0000000000..34fc7b9851 --- /dev/null +++ b/impls/bcpl/step5_tco.b @@ -0,0 +1,142 @@ +GET "libhdr" +GET "malhdr" + +GET "core.b" +GET "env.b" +GET "printer.b" +GET "reader.b" +GET "readline.b" +GET "types.b" + +LET READ(x) = read_str(x) + +// Helper function for EVAL. +LET is_sym(a, b) = VALOF +{ UNLESS type OF a = t_sym RESULTIS FALSE + RESULTIS str_eq_const(a, b) +} + +LET eval_ast(ast, env, gc_root) = VALOF + SWITCHON type OF ast INTO + { CASE t_sym: RESULTIS env_get(env, ast) + CASE t_lst: + TEST ast = empty THEN RESULTIS empty + ELSE + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET first = EVAL(ast!lst_first, env, gc_inner_root) + LET rest = eval_ast(ast!lst_rest, env, cons(first, gc_root)) + RESULTIS cons(first, rest) + } + CASE t_vec: + { LET new = alloc_vec(ast!vec_len) + LET gc_inner_root = alloc_vecn(4, new, ast, env, gc_root) + FOR i = 0 TO ast!vec_len - 1 DO + (new + vec_data)!i := EVAL((ast + vec_data)!i, env, gc_inner_root) + RESULTIS new + } + CASE t_hmx: + { LET gc_inner_root = cons(ast, gc_root) + RESULTIS alloc_hmx(ast!hmx_key, EVAL(ast!hmx_value, env, gc_inner_root)) + } + CASE t_hmi: + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET left = eval_ast(ast!hmi_left, env, gc_inner_root) + LET right = eval_ast(ast!hmi_right, env, cons(left, gc_inner_root)) + RESULTIS alloc_hmi(hmi_critbit OF ast, left, right) + } + DEFAULT: RESULTIS ast + } + +AND EVAL(ast, env, gc_root) = VALOF +{ MANIFEST { fun_binds = fun_data; fun_body; fun_env; fun_sz } + LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + gc(gc_inner_root) + UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env, gc_root) + IF ast = empty RESULTIS ast + { LET fn = ast!lst_first + IF is_sym(fn, "def!") THEN + { LET val = EVAL(nth(ast, 2), env, gc_inner_root) + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "let**") THEN + { LET newenv, bindings = env_new(env, empty, empty), as_lst(nth(ast, 1)) + gc_inner_root := alloc_vecn(3, newenv, bindings, gc_inner_root) + UNTIL bindings = empty DO + { env_set(newenv, bindings!lst_first, + EVAL(nth(bindings, 1), newenv, gc_inner_root)) + bindings := bindings!lst_rest!lst_rest + } + ast, env := nth(ast, 2), newenv + LOOP // TCO + } + IF is_sym(fn, "do") THEN + { LET tail = ast!lst_rest + UNTIL tail!lst_rest = empty DO + { EVAL(tail!lst_first, env, gc_inner_root) + tail := tail!lst_rest + } + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "if") THEN + { LET cond = EVAL(nth(ast, 1), env, gc_inner_root) + LET tail = ast!lst_rest!lst_rest + IF cond = nil | cond = mfalse THEN tail := tail!lst_rest + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "fn**") THEN + { LET call(fun, args, gc_root) = + EVAL(fun!fun_body, env_new(fun!fun_env, fun!fun_binds, args), gc_root) + LET result = alloc_fun(call, fun_sz, + as_lst(nth(ast, 1)), nth(ast, 2), env) + fun_ntracked OF result := 3 + type OF result := t_mfn + RESULTIS result + } + } + ast := eval_ast(ast, env, gc_root) + { LET fn, args = ast!lst_first, ast!lst_rest + UNLESS supertype OF fn = t_fun DO throwf("not a function") + IF type OF fn = t_mfn THEN + { ast, env := fn!fun_body, env_new(fn!fun_env, fn!fun_binds, args) + LOOP // TCO + } + RESULTIS (fn!fun_code)(fn, args, gc_root) + } +} REPEAT + +LET PRINT(x) = pr_str(x) + +STATIC { repl_env } + +LET rep(x) = PRINT(EVAL(READ(x), repl_env, nil)) + +LET repl() BE +{ repl_env := core_env() + rep(str_bcpl2mal("(def! not (fn** (a) (if a false true)))")) + catch_level, catch_label := level(), uncaught + IF FALSE THEN + { uncaught: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + } + { LET prompt = str_bcpl2mal("user> ") + LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + gc(repl_env) + } REPEAT +} + +LET start() = VALOF +{ LET ch = 0 + init_types() + ch := rdch() REPEATUNTIL ch = '*n' // Consume command-line args + wrch('*n') // Terminate prompt printed by Cintsys + repl() + RESULTIS 0 +} diff --git a/impls/bcpl/step6_file.b b/impls/bcpl/step6_file.b new file mode 100644 index 0000000000..1cd8536473 --- /dev/null +++ b/impls/bcpl/step6_file.b @@ -0,0 +1,192 @@ +GET "libhdr" +GET "malhdr" + +GET "core.b" +GET "env.b" +GET "printer.b" +GET "reader.b" +GET "readline.b" +GET "types.b" + +LET READ(x) = read_str(x) + +// Helper function for EVAL. +LET is_sym(a, b) = VALOF +{ UNLESS type OF a = t_sym RESULTIS FALSE + RESULTIS str_eq_const(a, b) +} + +LET eval_ast(ast, env, gc_root) = VALOF + SWITCHON type OF ast INTO + { CASE t_sym: RESULTIS env_get(env, ast) + CASE t_lst: + TEST ast = empty THEN RESULTIS empty + ELSE + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET first = EVAL(ast!lst_first, env, gc_inner_root) + LET rest = eval_ast(ast!lst_rest, env, cons(first, gc_root)) + RESULTIS cons(first, rest) + } + CASE t_vec: + { LET new = alloc_vec(ast!vec_len) + LET gc_inner_root = alloc_vecn(4, new, ast, env, gc_root) + FOR i = 0 TO ast!vec_len - 1 DO + (new + vec_data)!i := EVAL((ast + vec_data)!i, env, gc_inner_root) + RESULTIS new + } + CASE t_hmx: + { LET gc_inner_root = cons(ast, gc_root) + RESULTIS alloc_hmx(ast!hmx_key, EVAL(ast!hmx_value, env, gc_inner_root)) + } + CASE t_hmi: + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET left = eval_ast(ast!hmi_left, env, gc_inner_root) + LET right = eval_ast(ast!hmi_right, env, cons(left, gc_inner_root)) + RESULTIS alloc_hmi(hmi_critbit OF ast, left, right) + } + DEFAULT: RESULTIS ast + } + +AND EVAL(ast, env, gc_root) = VALOF +{ MANIFEST { fun_binds = fun_data; fun_body; fun_env; fun_sz } + LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + gc(gc_inner_root) + UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env, gc_root) + IF ast = empty RESULTIS ast + { LET fn = ast!lst_first + IF is_sym(fn, "def!") THEN + { LET val = EVAL(nth(ast, 2), env, gc_inner_root) + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "let**") THEN + { LET newenv, bindings = env_new(env, empty, empty), as_lst(nth(ast, 1)) + gc_inner_root := alloc_vecn(3, newenv, bindings, gc_inner_root) + UNTIL bindings = empty DO + { env_set(newenv, bindings!lst_first, + EVAL(nth(bindings, 1), newenv, gc_inner_root)) + bindings := bindings!lst_rest!lst_rest + } + ast, env := nth(ast, 2), newenv + LOOP // TCO + } + IF is_sym(fn, "do") THEN + { LET tail = ast!lst_rest + UNTIL tail!lst_rest = empty DO + { EVAL(tail!lst_first, env, gc_inner_root) + tail := tail!lst_rest + } + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "if") THEN + { LET cond = EVAL(nth(ast, 1), env, gc_inner_root) + LET tail = ast!lst_rest!lst_rest + IF cond = nil | cond = mfalse THEN tail := tail!lst_rest + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "fn**") THEN + { LET call(fun, args, gc_root) = + EVAL(fun!fun_body, env_new(fun!fun_env, fun!fun_binds, args), gc_root) + LET result = alloc_fun(call, fun_sz, + as_lst(nth(ast, 1)), nth(ast, 2), env) + fun_ntracked OF result := 3 + type OF result := t_mfn + RESULTIS result + } + } + ast := eval_ast(ast, env, gc_root) + { LET fn, args = ast!lst_first, ast!lst_rest + UNLESS supertype OF fn = t_fun DO throwf("not a function") + IF type OF fn = t_mfn THEN + { ast, env := fn!fun_body, env_new(fn!fun_env, fn!fun_binds, args) + LOOP // TCO + } + RESULTIS (fn!fun_code)(fn, args, gc_root) + } +} REPEAT + +LET PRINT(x) = pr_str(x) + +STATIC { repl_env } + +LET rep(x) = PRINT(EVAL(READ(x), repl_env, nil)) + +LET repl(argv) BE +{ LET mal_eval(fn, args, gc_root) = EVAL(args!lst_first, repl_env, gc_root) + catch_level, catch_label := level(), uncaught_exit + repl_env := core_env() + env_set(repl_env, as_sym(str_bcpl2mal("eval")), alloc_fun(mal_eval, fun_data)) + env_set(repl_env, as_sym(str_bcpl2mal("**FILE**")), argv!lst_first) + env_set(repl_env, as_sym(str_bcpl2mal("**ARGV**")), argv!lst_rest) + rep(str_bcpl2mal("(def! not (fn** (a) (if a false true)))"), repl_env) + rep(str_bcpl2mal("(def! load-file (fn** (f) (eval (read-string * + *(str *"(do *" (slurp f) *"*nnil)*")))))"), repl_env) + UNLESS argv = empty DO + { + rep(str_bcpl2mal("(load-file **FILE**)")) + sys(Sys_quit, 0) + uncaught_exit: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + sys(Sys_quit, 0) + } + catch_level, catch_label := level(), uncaught + IF FALSE THEN + { uncaught: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + } + { LET prompt = str_bcpl2mal("user> ") + LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + gc(repl_env) + } REPEAT +} + +// This is a cut-down version of the reader's tokenize function. + +// Cintsys passes us the entire command line as a single string and doesn't +// quote values in any way, so we can't reliably reconstruct arguments with +// whitespace in them. +LET read_argv() = VALOF +{ LET s = readline(str_bcpl2mal("")) + LET tokens, tailp = empty, @tokens + LET sd = s + str_data + LET tokstart, token = ?, ? + FOR p = 1 TO s!str_len DO + { tokstart := p + // Within this SWITCHON command, use LOOP to ignore input, or ENDCASE to + // emit a token. + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': LOOP // Inter-token whitespace + DEFAULT: // Word + WHILE p < s!str_len DO + { p := p + 1 + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': + p := p - 1; BREAK + } + } + ENDCASE + } + // At this point, tokstart points to the first character of the token, + // and p points to the last character. + token := str_substr(s, tokstart, p + 1) + !tailp := cons(token, empty) + tailp := @(!tailp)!lst_rest + } + RESULTIS tokens +} + +LET start() = VALOF +{ init_types() + wrch('*n') // Terminate prompt printed by Cintsys + repl(read_argv()) + RESULTIS 0 +} diff --git a/impls/bcpl/step7_quote.b b/impls/bcpl/step7_quote.b new file mode 100644 index 0000000000..dc72a168b4 --- /dev/null +++ b/impls/bcpl/step7_quote.b @@ -0,0 +1,214 @@ +GET "libhdr" +GET "malhdr" + +GET "core.b" +GET "env.b" +GET "printer.b" +GET "reader.b" +GET "readline.b" +GET "types.b" + +LET READ(x) = read_str(x) + +// Helper function for EVAL. +LET is_sym(a, b) = VALOF +{ UNLESS type OF a = t_sym RESULTIS FALSE + RESULTIS str_eq_const(a, b) +} + +LET is_pair(ast) = + type OF ast = t_lst & ast ~= empty | type OF ast = t_vec & ast!vec_len > 0 + +LET quasiquote(ast) = VALOF +{ UNLESS is_pair(ast) + RESULTIS cons(as_sym(str_bcpl2mal("quote")), cons(ast, empty)) + ast := as_lst(ast) + IF is_sym(ast!lst_first, "unquote") RESULTIS ast!lst_rest!lst_first + IF is_pair(ast!lst_first) & is_sym(ast!lst_first!lst_first, "splice-unquote") + RESULTIS cons(as_sym(str_bcpl2mal("concat")), + cons(ast!lst_first!lst_rest!lst_first, + cons(quasiquote(ast!lst_rest), empty))) + RESULTIS cons(as_sym(str_bcpl2mal("cons")), + cons(quasiquote(ast!lst_first), + cons(quasiquote(ast!lst_rest), empty))) +} + +LET eval_ast(ast, env, gc_root) = VALOF + SWITCHON type OF ast INTO + { CASE t_sym: RESULTIS env_get(env, ast) + CASE t_lst: + TEST ast = empty THEN RESULTIS empty + ELSE + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET first = EVAL(ast!lst_first, env, gc_inner_root) + LET rest = eval_ast(ast!lst_rest, env, cons(first, gc_root)) + RESULTIS cons(first, rest) + } + CASE t_vec: + { LET new = alloc_vec(ast!vec_len) + LET gc_inner_root = alloc_vecn(4, new, ast, env, gc_root) + FOR i = 0 TO ast!vec_len - 1 DO + (new + vec_data)!i := EVAL((ast + vec_data)!i, env, gc_inner_root) + RESULTIS new + } + CASE t_hmx: + { LET gc_inner_root = cons(ast, gc_root) + RESULTIS alloc_hmx(ast!hmx_key, EVAL(ast!hmx_value, env, gc_inner_root)) + } + CASE t_hmi: + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET left = eval_ast(ast!hmi_left, env, gc_inner_root) + LET right = eval_ast(ast!hmi_right, env, cons(left, gc_inner_root)) + RESULTIS alloc_hmi(hmi_critbit OF ast, left, right) + } + DEFAULT: RESULTIS ast + } + +AND EVAL(ast, env, gc_root) = VALOF +{ MANIFEST { fun_binds = fun_data; fun_body; fun_env; fun_sz } + LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + gc(gc_inner_root) + UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env, gc_root) + IF ast = empty RESULTIS ast + { LET fn = ast!lst_first + IF is_sym(fn, "def!") THEN + { LET val = EVAL(nth(ast, 2), env, gc_inner_root) + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "let**") THEN + { LET newenv, bindings = env_new(env, empty, empty), as_lst(nth(ast, 1)) + gc_inner_root := alloc_vecn(3, newenv, bindings, gc_inner_root) + UNTIL bindings = empty DO + { env_set(newenv, bindings!lst_first, + EVAL(nth(bindings, 1), newenv, gc_inner_root)) + bindings := bindings!lst_rest!lst_rest + } + ast, env := nth(ast, 2), newenv + LOOP // TCO + } + IF is_sym(fn, "quote") RESULTIS ast!lst_rest!lst_first + IF is_sym(fn, "quasiquote") THEN + { ast := quasiquote(ast!lst_rest!lst_first) + LOOP // TCO + } + IF is_sym(fn, "do") THEN + { LET tail = ast!lst_rest + UNTIL tail!lst_rest = empty DO + { EVAL(tail!lst_first, env, gc_inner_root) + tail := tail!lst_rest + } + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "if") THEN + { LET cond = EVAL(nth(ast, 1), env, gc_inner_root) + LET tail = ast!lst_rest!lst_rest + IF cond = nil | cond = mfalse THEN tail := tail!lst_rest + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "fn**") THEN + { LET call(fun, args, gc_root) = + EVAL(fun!fun_body, env_new(fun!fun_env, fun!fun_binds, args), gc_root) + LET result = alloc_fun(call, fun_sz, + as_lst(nth(ast, 1)), nth(ast, 2), env) + fun_ntracked OF result := 3 + type OF result := t_mfn + RESULTIS result + } + } + ast := eval_ast(ast, env, gc_root) + { LET fn, args = ast!lst_first, ast!lst_rest + UNLESS supertype OF fn = t_fun DO throwf("not a function") + IF type OF fn = t_mfn THEN + { ast, env := fn!fun_body, env_new(fn!fun_env, fn!fun_binds, args) + LOOP // TCO + } + RESULTIS (fn!fun_code)(fn, args, gc_root) + } +} REPEAT + +LET PRINT(x) = pr_str(x) + +STATIC { repl_env } + +LET rep(x) = PRINT(EVAL(READ(x), repl_env, nil)) + +LET repl(argv) BE +{ LET mal_eval(fn, args, gc_root) = EVAL(args!lst_first, repl_env, gc_root) + catch_level, catch_label := level(), uncaught_exit + repl_env := core_env() + env_set(repl_env, as_sym(str_bcpl2mal("eval")), alloc_fun(mal_eval, fun_data)) + env_set(repl_env, as_sym(str_bcpl2mal("**FILE**")), argv!lst_first) + env_set(repl_env, as_sym(str_bcpl2mal("**ARGV**")), argv!lst_rest) + rep(str_bcpl2mal("(def! not (fn** (a) (if a false true)))"), repl_env) + rep(str_bcpl2mal("(def! load-file (fn** (f) (eval (read-string * + *(str *"(do *" (slurp f) *"*nnil)*")))))"), repl_env) + UNLESS argv = empty DO + { + rep(str_bcpl2mal("(load-file **FILE**)")) + sys(Sys_quit, 0) + uncaught_exit: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + sys(Sys_quit, 0) + } + catch_level, catch_label := level(), uncaught + IF FALSE THEN + { uncaught: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + } + { LET prompt = str_bcpl2mal("user> ") + LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + gc(repl_env) + } REPEAT +} + +// This is a cut-down version of the reader's tokenize function. + +// Cintsys passes us the entire command line as a single string and doesn't +// quote values in any way, so we can't reliably reconstruct arguments with +// whitespace in them. +LET read_argv() = VALOF +{ LET s = readline(str_bcpl2mal("")) + LET tokens, tailp = empty, @tokens + LET sd = s + str_data + LET tokstart, token = ?, ? + FOR p = 1 TO s!str_len DO + { tokstart := p + // Within this SWITCHON command, use LOOP to ignore input, or ENDCASE to + // emit a token. + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': LOOP // Inter-token whitespace + DEFAULT: // Word + WHILE p < s!str_len DO + { p := p + 1 + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': + p := p - 1; BREAK + } + } + ENDCASE + } + // At this point, tokstart points to the first character of the token, + // and p points to the last character. + token := str_substr(s, tokstart, p + 1) + !tailp := cons(token, empty) + tailp := @(!tailp)!lst_rest + } + RESULTIS tokens +} + +LET start() = VALOF +{ init_types() + wrch('*n') // Terminate prompt printed by Cintsys + repl(read_argv()) + RESULTIS 0 +} diff --git a/impls/bcpl/step8_macros.b b/impls/bcpl/step8_macros.b new file mode 100644 index 0000000000..5c09311359 --- /dev/null +++ b/impls/bcpl/step8_macros.b @@ -0,0 +1,245 @@ +GET "libhdr" +GET "malhdr" + +GET "core.b" +GET "env.b" +GET "printer.b" +GET "reader.b" +GET "readline.b" +GET "types.b" + +LET READ(x) = read_str(x) + +// Helper function for EVAL. +LET is_sym(a, b) = VALOF +{ UNLESS type OF a = t_sym RESULTIS FALSE + RESULTIS str_eq_const(a, b) +} + +LET is_pair(ast) = + type OF ast = t_lst & ast ~= empty | type OF ast = t_vec & ast!vec_len > 0 + +LET quasiquote(ast) = VALOF +{ UNLESS is_pair(ast) + RESULTIS cons(as_sym(str_bcpl2mal("quote")), cons(ast, empty)) + ast := as_lst(ast) + IF is_sym(ast!lst_first, "unquote") RESULTIS ast!lst_rest!lst_first + IF is_pair(ast!lst_first) & is_sym(ast!lst_first!lst_first, "splice-unquote") + RESULTIS cons(as_sym(str_bcpl2mal("concat")), + cons(ast!lst_first!lst_rest!lst_first, + cons(quasiquote(ast!lst_rest), empty))) + RESULTIS cons(as_sym(str_bcpl2mal("cons")), + cons(quasiquote(ast!lst_first), + cons(quasiquote(ast!lst_rest), empty))) +} + +LET is_macro_call(ast, env) = VALOF +{ LET fn = ? + UNLESS type OF ast = t_lst & type OF (ast!lst_first) = t_sym & + env_find(env, ast!lst_first) ~= nil RESULTIS FALSE + fn := env_get(env, ast!lst_first) + RESULTIS type OF fn = t_mfn & mfn_ismacro OF fn ~= 0 +} + +LET macroexpand(ast, env, gc_root) = VALOF +{ WHILE is_macro_call(ast, env) DO + { LET fn = env_get(env, ast!lst_first) + ast := (fn!fun_code)(fn, ast!lst_rest, gc_root) + } + RESULTIS ast +} + +LET eval_ast(ast, env, gc_root) = VALOF + SWITCHON type OF ast INTO + { CASE t_sym: RESULTIS env_get(env, ast) + CASE t_lst: + TEST ast = empty THEN RESULTIS empty + ELSE + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET first = EVAL(ast!lst_first, env, gc_inner_root) + LET rest = eval_ast(ast!lst_rest, env, cons(first, gc_root)) + RESULTIS cons(first, rest) + } + CASE t_vec: + { LET new = alloc_vec(ast!vec_len) + LET gc_inner_root = alloc_vecn(4, new, ast, env, gc_root) + FOR i = 0 TO ast!vec_len - 1 DO + (new + vec_data)!i := EVAL((ast + vec_data)!i, env, gc_inner_root) + RESULTIS new + } + CASE t_hmx: + { LET gc_inner_root = cons(ast, gc_root) + RESULTIS alloc_hmx(ast!hmx_key, EVAL(ast!hmx_value, env, gc_inner_root)) + } + CASE t_hmi: + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET left = eval_ast(ast!hmi_left, env, gc_inner_root) + LET right = eval_ast(ast!hmi_right, env, cons(left, gc_inner_root)) + RESULTIS alloc_hmi(hmi_critbit OF ast, left, right) + } + DEFAULT: RESULTIS ast + } + +AND EVAL(ast, env, gc_root) = VALOF +{ MANIFEST { fun_binds = fun_data; fun_body; fun_env; fun_sz } + LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + gc(gc_inner_root) + UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env, gc_root) + ast := macroexpand(ast, env, gc_inner_root) + (gc_inner_root+vec_data)!0 := ast // In case it has changed. + UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env, gc_root) + IF ast = empty RESULTIS ast + { LET fn = ast!lst_first + IF is_sym(fn, "def!") THEN + { LET val = EVAL(nth(ast, 2), env, gc_inner_root) + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "let**") THEN + { LET newenv, bindings = env_new(env, empty, empty), as_lst(nth(ast, 1)) + gc_inner_root := alloc_vecn(3, newenv, bindings, gc_inner_root) + UNTIL bindings = empty DO + { env_set(newenv, bindings!lst_first, + EVAL(nth(bindings, 1), newenv, gc_inner_root)) + bindings := bindings!lst_rest!lst_rest + } + ast, env := nth(ast, 2), newenv + LOOP // TCO + } + IF is_sym(fn, "quote") RESULTIS ast!lst_rest!lst_first + IF is_sym(fn, "quasiquote") THEN + { ast := quasiquote(ast!lst_rest!lst_first) + LOOP // TCO + } + IF is_sym(fn, "defmacro!") THEN + { LET val = EVAL(nth(ast, 2), env, gc_inner_root) + IF type OF val = t_mfn THEN mfn_ismacro OF val := 1 + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "macroexpand") THEN + RESULTIS macroexpand(ast!lst_rest!lst_first, env, gc_root) + IF is_sym(fn, "do") THEN + { LET tail = ast!lst_rest + UNTIL tail!lst_rest = empty DO + { EVAL(tail!lst_first, env, gc_inner_root) + tail := tail!lst_rest + } + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "if") THEN + { LET cond = EVAL(nth(ast, 1), env, gc_inner_root) + LET tail = ast!lst_rest!lst_rest + IF cond = nil | cond = mfalse THEN tail := tail!lst_rest + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "fn**") THEN + { LET call(fun, args, gc_root) = + EVAL(fun!fun_body, env_new(fun!fun_env, fun!fun_binds, args), gc_root) + LET result = alloc_fun(call, fun_sz, + as_lst(nth(ast, 1)), nth(ast, 2), env) + fun_ntracked OF result := 3 + type OF result := t_mfn + RESULTIS result + } + } + ast := eval_ast(ast, env, gc_root) + { LET fn, args = ast!lst_first, ast!lst_rest + UNLESS supertype OF fn = t_fun DO throwf("not a function") + IF type OF fn = t_mfn THEN + { ast, env := fn!fun_body, env_new(fn!fun_env, fn!fun_binds, args) + LOOP // TCO + } + RESULTIS (fn!fun_code)(fn, args, gc_root) + } +} REPEAT + +LET PRINT(x) = pr_str(x) + +STATIC { repl_env } + +LET rep(x) = PRINT(EVAL(READ(x), repl_env, nil)) + +LET repl(argv) BE +{ LET mal_eval(fn, args, gc_root) = EVAL(args!lst_first, repl_env, gc_root) + catch_level, catch_label := level(), uncaught_exit + repl_env := core_env() + env_set(repl_env, as_sym(str_bcpl2mal("eval")), alloc_fun(mal_eval, fun_data)) + env_set(repl_env, as_sym(str_bcpl2mal("**FILE**")), argv!lst_first) + env_set(repl_env, as_sym(str_bcpl2mal("**ARGV**")), argv!lst_rest) + rep(str_bcpl2mal("(def! not (fn** (a) (if a false true)))"), repl_env) + rep(str_bcpl2mal("(def! load-file (fn** (f) (eval (read-string * + *(str *"(do *" (slurp f) *"*nnil)*")))))"), repl_env) + rep(str_bcpl2mal("(defmacro! cond (fn** (& xs) (if (> (count xs) 0) * + *(list 'if (first xs) (if (> (count xs) 1) (nth xs 1) * + *(throw *"odd number of forms to cond*")) * + *(cons 'cond (rest (rest xs)))))))"), repl_env) + UNLESS argv = empty DO + { + rep(str_bcpl2mal("(load-file **FILE**)")) + sys(Sys_quit, 0) + uncaught_exit: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + sys(Sys_quit, 0) + } + catch_level, catch_label := level(), uncaught + IF FALSE THEN + { uncaught: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + } + { LET prompt = str_bcpl2mal("user> ") + LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + gc(repl_env) + } REPEAT +} + +// This is a cut-down version of the reader's tokenize function. + +// Cintsys passes us the entire command line as a single string and doesn't +// quote values in any way, so we can't reliably reconstruct arguments with +// whitespace in them. +LET read_argv() = VALOF +{ LET s = readline(str_bcpl2mal("")) + LET tokens, tailp = empty, @tokens + LET sd = s + str_data + LET tokstart, token = ?, ? + FOR p = 1 TO s!str_len DO + { tokstart := p + // Within this SWITCHON command, use LOOP to ignore input, or ENDCASE to + // emit a token. + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': LOOP // Inter-token whitespace + DEFAULT: // Word + WHILE p < s!str_len DO + { p := p + 1 + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': + p := p - 1; BREAK + } + } + ENDCASE + } + // At this point, tokstart points to the first character of the token, + // and p points to the last character. + token := str_substr(s, tokstart, p + 1) + !tailp := cons(token, empty) + tailp := @(!tailp)!lst_rest + } + RESULTIS tokens +} + +LET start() = VALOF +{ init_types() + wrch('*n') // Terminate prompt printed by Cintsys + repl(read_argv()) + RESULTIS 0 +} diff --git a/impls/bcpl/step9_try.b b/impls/bcpl/step9_try.b new file mode 100644 index 0000000000..3e7d1eea7a --- /dev/null +++ b/impls/bcpl/step9_try.b @@ -0,0 +1,261 @@ +GET "libhdr" +GET "malhdr" + +GET "core.b" +GET "env.b" +GET "printer.b" +GET "reader.b" +GET "readline.b" +GET "types.b" + +LET READ(x) = read_str(x) + +// Helper function for EVAL. +LET is_sym(a, b) = VALOF +{ UNLESS type OF a = t_sym RESULTIS FALSE + RESULTIS str_eq_const(a, b) +} + +LET is_pair(ast) = + type OF ast = t_lst & ast ~= empty | type OF ast = t_vec & ast!vec_len > 0 + +LET quasiquote(ast) = VALOF +{ UNLESS is_pair(ast) + RESULTIS cons(as_sym(str_bcpl2mal("quote")), cons(ast, empty)) + ast := as_lst(ast) + IF is_sym(ast!lst_first, "unquote") RESULTIS ast!lst_rest!lst_first + IF is_pair(ast!lst_first) & is_sym(ast!lst_first!lst_first, "splice-unquote") + RESULTIS cons(as_sym(str_bcpl2mal("concat")), + cons(ast!lst_first!lst_rest!lst_first, + cons(quasiquote(ast!lst_rest), empty))) + RESULTIS cons(as_sym(str_bcpl2mal("cons")), + cons(quasiquote(ast!lst_first), + cons(quasiquote(ast!lst_rest), empty))) +} + +LET is_macro_call(ast, env) = VALOF +{ LET fn = ? + UNLESS type OF ast = t_lst & type OF (ast!lst_first) = t_sym & + env_find(env, ast!lst_first) ~= nil RESULTIS FALSE + fn := env_get(env, ast!lst_first) + RESULTIS type OF fn = t_mfn & mfn_ismacro OF fn ~= 0 +} + +LET macroexpand(ast, env, gc_root) = VALOF +{ WHILE is_macro_call(ast, env) DO + { LET fn = env_get(env, ast!lst_first) + ast := (fn!fun_code)(fn, ast!lst_rest, gc_root) + } + RESULTIS ast +} + +LET eval_ast(ast, env, gc_root) = VALOF + SWITCHON type OF ast INTO + { CASE t_sym: RESULTIS env_get(env, ast) + CASE t_lst: + TEST ast = empty THEN RESULTIS empty + ELSE + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET first = EVAL(ast!lst_first, env, gc_inner_root) + LET rest = eval_ast(ast!lst_rest, env, cons(first, gc_root)) + RESULTIS cons(first, rest) + } + CASE t_vec: + { LET new = alloc_vec(ast!vec_len) + LET gc_inner_root = alloc_vecn(4, new, ast, env, gc_root) + FOR i = 0 TO ast!vec_len - 1 DO + (new + vec_data)!i := EVAL((ast + vec_data)!i, env, gc_inner_root) + RESULTIS new + } + CASE t_hmx: + { LET gc_inner_root = cons(ast, gc_root) + RESULTIS alloc_hmx(ast!hmx_key, EVAL(ast!hmx_value, env, gc_inner_root)) + } + CASE t_hmi: + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET left = eval_ast(ast!hmi_left, env, gc_inner_root) + LET right = eval_ast(ast!hmi_right, env, cons(left, gc_inner_root)) + RESULTIS alloc_hmi(hmi_critbit OF ast, left, right) + } + DEFAULT: RESULTIS ast + } + +AND EVAL(ast, env, gc_root) = VALOF +{ MANIFEST { fun_binds = fun_data; fun_body; fun_env; fun_sz } + LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + gc(gc_inner_root) + UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env, gc_root) + ast := macroexpand(ast, env, gc_inner_root) + (gc_inner_root+vec_data)!0 := ast // In case it has changed. + UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env, gc_root) + IF ast = empty RESULTIS ast + { LET fn = ast!lst_first + IF is_sym(fn, "def!") THEN + { LET val = EVAL(nth(ast, 2), env, gc_inner_root) + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "let**") THEN + { LET newenv, bindings = env_new(env, empty, empty), as_lst(nth(ast, 1)) + gc_inner_root := alloc_vecn(3, newenv, bindings, gc_inner_root) + UNTIL bindings = empty DO + { env_set(newenv, bindings!lst_first, + EVAL(nth(bindings, 1), newenv, gc_inner_root)) + bindings := bindings!lst_rest!lst_rest + } + ast, env := nth(ast, 2), newenv + LOOP // TCO + } + IF is_sym(fn, "quote") RESULTIS ast!lst_rest!lst_first + IF is_sym(fn, "quasiquote") THEN + { ast := quasiquote(ast!lst_rest!lst_first) + LOOP // TCO + } + IF is_sym(fn, "defmacro!") THEN + { LET val = EVAL(nth(ast, 2), env, gc_inner_root) + IF type OF val = t_mfn THEN mfn_ismacro OF val := 1 + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "macroexpand") THEN + RESULTIS macroexpand(ast!lst_rest!lst_first, env, gc_root) + IF is_sym(fn, "try**") THEN + { LET old_catch_level, old_catch_label = catch_level, catch_label + LET result, catcher = ?, ? + catch_level, catch_label := level(), catch + result := EVAL(ast!lst_rest!lst_first, env, gc_inner_root) + catch_level, catch_label := old_catch_level, old_catch_label + RESULTIS result + catch: + catch_level, catch_label := old_catch_level, old_catch_label + catcher := ast!lst_rest!lst_rest!lst_first + IF catcher = nil THEN throw(last_exception) + env := env_new(env, empty, empty) + env_set(env, nth(catcher, 1), last_exception) + ast := nth(catcher, 2) + LOOP // TCO + } + IF is_sym(fn, "do") THEN + { LET tail = ast!lst_rest + UNTIL tail!lst_rest = empty DO + { EVAL(tail!lst_first, env, gc_inner_root) + tail := tail!lst_rest + } + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "if") THEN + { LET cond = EVAL(nth(ast, 1), env, gc_inner_root) + LET tail = ast!lst_rest!lst_rest + IF cond = nil | cond = mfalse THEN tail := tail!lst_rest + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "fn**") THEN + { LET call(fun, args, gc_root) = + EVAL(fun!fun_body, env_new(fun!fun_env, fun!fun_binds, args), gc_root) + LET result = alloc_fun(call, fun_sz, + as_lst(nth(ast, 1)), nth(ast, 2), env) + fun_ntracked OF result := 3 + type OF result := t_mfn + RESULTIS result + } + } + ast := eval_ast(ast, env, gc_root) + { LET fn, args = ast!lst_first, ast!lst_rest + UNLESS supertype OF fn = t_fun DO throwf("not a function") + IF type OF fn = t_mfn THEN + { ast, env := fn!fun_body, env_new(fn!fun_env, fn!fun_binds, args) + LOOP // TCO + } + RESULTIS (fn!fun_code)(fn, args, gc_root) + } +} REPEAT + +LET PRINT(x) = pr_str(x) + +STATIC { repl_env } + +LET rep(x) = PRINT(EVAL(READ(x), repl_env, nil)) + +LET repl(argv) BE +{ LET mal_eval(fn, args, gc_root) = EVAL(args!lst_first, repl_env, gc_root) + catch_level, catch_label := level(), uncaught_exit + repl_env := core_env() + env_set(repl_env, as_sym(str_bcpl2mal("eval")), alloc_fun(mal_eval, fun_data)) + env_set(repl_env, as_sym(str_bcpl2mal("**FILE**")), argv!lst_first) + env_set(repl_env, as_sym(str_bcpl2mal("**ARGV**")), argv!lst_rest) + rep(str_bcpl2mal("(def! not (fn** (a) (if a false true)))"), repl_env) + rep(str_bcpl2mal("(def! load-file (fn** (f) (eval (read-string * + *(str *"(do *" (slurp f) *"*nnil)*")))))"), repl_env) + rep(str_bcpl2mal("(defmacro! cond (fn** (& xs) (if (> (count xs) 0) * + *(list 'if (first xs) (if (> (count xs) 1) (nth xs 1) * + *(throw *"odd number of forms to cond*")) * + *(cons 'cond (rest (rest xs)))))))"), repl_env) + UNLESS argv = empty DO + { + rep(str_bcpl2mal("(load-file **FILE**)")) + sys(Sys_quit, 0) + uncaught_exit: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + sys(Sys_quit, 0) + } + catch_level, catch_label := level(), uncaught + IF FALSE THEN + { uncaught: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + } + { LET prompt = str_bcpl2mal("user> ") + LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + gc(repl_env) + } REPEAT +} + +// This is a cut-down version of the reader's tokenize function. + +// Cintsys passes us the entire command line as a single string and doesn't +// quote values in any way, so we can't reliably reconstruct arguments with +// whitespace in them. +LET read_argv() = VALOF +{ LET s = readline(str_bcpl2mal("")) + LET tokens, tailp = empty, @tokens + LET sd = s + str_data + LET tokstart, token = ?, ? + FOR p = 1 TO s!str_len DO + { tokstart := p + // Within this SWITCHON command, use LOOP to ignore input, or ENDCASE to + // emit a token. + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': LOOP // Inter-token whitespace + DEFAULT: // Word + WHILE p < s!str_len DO + { p := p + 1 + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': + p := p - 1; BREAK + } + } + ENDCASE + } + // At this point, tokstart points to the first character of the token, + // and p points to the last character. + token := str_substr(s, tokstart, p + 1) + !tailp := cons(token, empty) + tailp := @(!tailp)!lst_rest + } + RESULTIS tokens +} + +LET start() = VALOF +{ init_types() + wrch('*n') // Terminate prompt printed by Cintsys + repl(read_argv()) + RESULTIS 0 +} diff --git a/impls/bcpl/stepA_mal.b b/impls/bcpl/stepA_mal.b new file mode 100644 index 0000000000..c256403555 --- /dev/null +++ b/impls/bcpl/stepA_mal.b @@ -0,0 +1,264 @@ +GET "libhdr" +GET "malhdr" + +GET "core.b" +GET "env.b" +GET "printer.b" +GET "reader.b" +GET "readline.b" +GET "types.b" + +LET READ(x) = read_str(x) + +// Helper function for EVAL. +LET is_sym(a, b) = VALOF +{ UNLESS type OF a = t_sym RESULTIS FALSE + RESULTIS str_eq_const(a, b) +} + +LET is_pair(ast) = + type OF ast = t_lst & ast ~= empty | type OF ast = t_vec & ast!vec_len > 0 + +LET quasiquote(ast) = VALOF +{ UNLESS is_pair(ast) + RESULTIS cons(as_sym(str_bcpl2mal("quote")), cons(ast, empty)) + ast := as_lst(ast) + IF is_sym(ast!lst_first, "unquote") RESULTIS ast!lst_rest!lst_first + IF is_pair(ast!lst_first) & is_sym(ast!lst_first!lst_first, "splice-unquote") + RESULTIS cons(as_sym(str_bcpl2mal("concat")), + cons(ast!lst_first!lst_rest!lst_first, + cons(quasiquote(ast!lst_rest), empty))) + RESULTIS cons(as_sym(str_bcpl2mal("cons")), + cons(quasiquote(ast!lst_first), + cons(quasiquote(ast!lst_rest), empty))) +} + +LET is_macro_call(ast, env) = VALOF +{ LET fn = ? + UNLESS type OF ast = t_lst & type OF (ast!lst_first) = t_sym & + env_find(env, ast!lst_first) ~= nil RESULTIS FALSE + fn := env_get(env, ast!lst_first) + RESULTIS type OF fn = t_mfn & mfn_ismacro OF fn ~= 0 +} + +LET macroexpand(ast, env, gc_root) = VALOF +{ WHILE is_macro_call(ast, env) DO + { LET fn = env_get(env, ast!lst_first) + ast := (fn!fun_code)(fn, ast!lst_rest, gc_root) + } + RESULTIS ast +} + +LET eval_ast(ast, env, gc_root) = VALOF + SWITCHON type OF ast INTO + { CASE t_sym: RESULTIS env_get(env, ast) + CASE t_lst: + TEST ast = empty THEN RESULTIS empty + ELSE + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET first = EVAL(ast!lst_first, env, gc_inner_root) + LET rest = eval_ast(ast!lst_rest, env, cons(first, gc_root)) + RESULTIS cons(first, rest) + } + CASE t_vec: + { LET new = alloc_vec(ast!vec_len) + LET gc_inner_root = alloc_vecn(4, new, ast, env, gc_root) + FOR i = 0 TO ast!vec_len - 1 DO + (new + vec_data)!i := EVAL((ast + vec_data)!i, env, gc_inner_root) + RESULTIS new + } + CASE t_hmx: + { LET gc_inner_root = cons(ast, gc_root) + RESULTIS alloc_hmx(ast!hmx_key, EVAL(ast!hmx_value, env, gc_inner_root)) + } + CASE t_hmi: + { LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + LET left = eval_ast(ast!hmi_left, env, gc_inner_root) + LET right = eval_ast(ast!hmi_right, env, cons(left, gc_inner_root)) + RESULTIS alloc_hmi(hmi_critbit OF ast, left, right) + } + DEFAULT: RESULTIS ast + } + +AND EVAL(ast, env, gc_root) = VALOF +{ MANIFEST { fun_binds = fun_data; fun_body; fun_env; fun_sz } + LET gc_inner_root = alloc_vecn(3, ast, env, gc_root) + gc(gc_inner_root) + UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env, gc_root) + ast := macroexpand(ast, env, gc_inner_root) + (gc_inner_root+vec_data)!0 := ast // In case it has changed. + UNLESS type OF ast = t_lst RESULTIS eval_ast(ast, env, gc_root) + IF ast = empty RESULTIS ast + { LET fn = ast!lst_first + IF is_sym(fn, "def!") THEN + { LET val = EVAL(nth(ast, 2), env, gc_inner_root) + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "let**") THEN + { LET newenv, bindings = env_new(env, empty, empty), as_lst(nth(ast, 1)) + gc_inner_root := alloc_vecn(3, newenv, bindings, gc_inner_root) + UNTIL bindings = empty DO + { env_set(newenv, bindings!lst_first, + EVAL(nth(bindings, 1), newenv, gc_inner_root)) + bindings := bindings!lst_rest!lst_rest + } + ast, env := nth(ast, 2), newenv + LOOP // TCO + } + IF is_sym(fn, "quote") RESULTIS ast!lst_rest!lst_first + IF is_sym(fn, "quasiquote") THEN + { ast := quasiquote(ast!lst_rest!lst_first) + LOOP // TCO + } + IF is_sym(fn, "defmacro!") THEN + { LET val = EVAL(nth(ast, 2), env, gc_inner_root) + IF type OF val = t_mfn THEN mfn_ismacro OF val := 1 + env_set(env, nth(ast, 1), val, env) + RESULTIS val + } + IF is_sym(fn, "macroexpand") THEN + RESULTIS macroexpand(ast!lst_rest!lst_first, env, gc_root) + IF is_sym(fn, "try**") THEN + { LET old_catch_level, old_catch_label = catch_level, catch_label + LET result, catcher = ?, ? + catch_level, catch_label := level(), catch + result := EVAL(ast!lst_rest!lst_first, env, gc_inner_root) + catch_level, catch_label := old_catch_level, old_catch_label + RESULTIS result + catch: + catch_level, catch_label := old_catch_level, old_catch_label + catcher := ast!lst_rest!lst_rest!lst_first + IF catcher = nil THEN throw(last_exception) + env := env_new(env, empty, empty) + env_set(env, nth(catcher, 1), last_exception) + ast := nth(catcher, 2) + LOOP // TCO + } + IF is_sym(fn, "do") THEN + { LET tail = ast!lst_rest + UNTIL tail!lst_rest = empty DO + { EVAL(tail!lst_first, env, gc_inner_root) + tail := tail!lst_rest + } + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "if") THEN + { LET cond = EVAL(nth(ast, 1), env, gc_inner_root) + LET tail = ast!lst_rest!lst_rest + IF cond = nil | cond = mfalse THEN tail := tail!lst_rest + ast := tail!lst_first + LOOP // TCO + } + IF is_sym(fn, "fn**") THEN + { LET call(fun, args, gc_root) = + EVAL(fun!fun_body, env_new(fun!fun_env, fun!fun_binds, args), gc_root) + LET result = alloc_fun(call, fun_sz, + as_lst(nth(ast, 1)), nth(ast, 2), env) + fun_ntracked OF result := 3 + type OF result := t_mfn + RESULTIS result + } + } + ast := eval_ast(ast, env, gc_root) + { LET fn, args = ast!lst_first, ast!lst_rest + UNLESS supertype OF fn = t_fun DO throwf("not a function") + IF type OF fn = t_mfn THEN + { ast, env := fn!fun_body, env_new(fn!fun_env, fn!fun_binds, args) + LOOP // TCO + } + RESULTIS (fn!fun_code)(fn, args, gc_root) + } +} REPEAT + +LET PRINT(x) = pr_str(x) + +STATIC { repl_env } + +LET rep(x) = PRINT(EVAL(READ(x), repl_env, nil)) + +LET repl(argv) BE +{ LET mal_eval(fn, args, gc_root) = EVAL(args!lst_first, repl_env, gc_root) + catch_level, catch_label := level(), uncaught_exit + repl_env := core_env() + env_set(repl_env, as_sym(str_bcpl2mal("eval")), alloc_fun(mal_eval, fun_data)) + env_set(repl_env, as_sym(str_bcpl2mal("**FILE**")), argv!lst_first) + env_set(repl_env, as_sym(str_bcpl2mal("**ARGV**")), argv!lst_rest) + env_set(repl_env, as_sym(str_bcpl2mal("**host-language**")), + str_bcpl2mal("BCPL")) + rep(str_bcpl2mal("(def! not (fn** (a) (if a false true)))"), repl_env) + rep(str_bcpl2mal("(def! load-file (fn** (f) (eval (read-string * + *(str *"(do *" (slurp f) *"*nnil)*")))))"), repl_env) + rep(str_bcpl2mal("(defmacro! cond (fn** (& xs) (if (> (count xs) 0) * + *(list 'if (first xs) (if (> (count xs) 1) (nth xs 1) * + *(throw *"odd number of forms to cond*")) * + *(cons 'cond (rest (rest xs)))))))"), repl_env) + UNLESS argv = empty DO + { + rep(str_bcpl2mal("(load-file **FILE**)")) + sys(Sys_quit, 0) + uncaught_exit: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + sys(Sys_quit, 0) + } + rep(str_bcpl2mal("(println (str *"Mal [*" **host-language** *"]*"))")) + catch_level, catch_label := level(), uncaught + IF FALSE THEN + { uncaught: + writes("Uncaught exception: ") + writes(@(pr_str(last_exception)!str_data)) + newline() + } + { LET prompt = str_bcpl2mal("user> ") + LET line = readline(prompt) + IF line = nil THEN BREAK + writes(@rep(line)!str_data) + newline() + gc(repl_env) + } REPEAT +} + +// This is a cut-down version of the reader's tokenize function. + +// Cintsys passes us the entire command line as a single string and doesn't +// quote values in any way, so we can't reliably reconstruct arguments with +// whitespace in them. +LET read_argv() = VALOF +{ LET s = readline(str_bcpl2mal("")) + LET tokens, tailp = empty, @tokens + LET sd = s + str_data + LET tokstart, token = ?, ? + FOR p = 1 TO s!str_len DO + { tokstart := p + // Within this SWITCHON command, use LOOP to ignore input, or ENDCASE to + // emit a token. + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': LOOP // Inter-token whitespace + DEFAULT: // Word + WHILE p < s!str_len DO + { p := p + 1 + SWITCHON sd%p INTO + { CASE ' ': CASE '*t': CASE '*n': + p := p - 1; BREAK + } + } + ENDCASE + } + // At this point, tokstart points to the first character of the token, + // and p points to the last character. + token := str_substr(s, tokstart, p + 1) + !tailp := cons(token, empty) + tailp := @(!tailp)!lst_rest + } + RESULTIS tokens +} + +LET start() = VALOF +{ init_types() + wrch('*n') // Terminate prompt printed by Cintsys + repl(read_argv()) + RESULTIS 0 +} diff --git a/impls/bcpl/types.b b/impls/bcpl/types.b new file mode 100644 index 0000000000..91c3e562c8 --- /dev/null +++ b/impls/bcpl/types.b @@ -0,0 +1,410 @@ +GET "libhdr" +GET "malhdr" + +LET init_types() BE +{ // These objects are statically-allocated and hence special. + // nil acts as the head and tail of the global object list. + nil := TABLE ?, t_nil + nil!nextptr := nil + empty := TABLE ?, t_lst, ?, ? + empty!lst_first, empty!lst_rest := nil, empty + empty_hashmap := TABLE ?, t_hm0 + mtrue := TABLE ?, t_boo, TRUE + mfalse := TABLE ?, t_boo, FALSE +} + +STATIC { new_objects = 0; old_objects = 0 } + +LET alloc_val(size) = VALOF +{ LET result = getvec(size) + result!1 := 0 // Make sure type word is all zeroes. + result!nextptr := nil!nextptr + nil!nextptr := result + new_objects := new_objects + 1 + // writef("ALLOC: <- %8x*n", result) + RESULTIS result +} + +LET gc_mark(x) BE +{ IF gc_marked OF x = 1 THEN RETURN + // writef("MARK : -- %8x (%8x)*n", x, x!1) + gc_marked OF x := 1 + // Note manual tail-call elimination here so that marking a long + // list doesn't cause a stack overflow. Other large data structures + // still could, though. + SWITCHON supertype OF x INTO + { CASE t_lst: gc_mark(x!lst_first); x := x!lst_rest; LOOP + CASE t_vec: FOR i = 0 TO x!vec_len - 1 DO + gc_mark((x+vec_data)!i) + ENDCASE + CASE t_hmi: gc_mark(x!hmi_left); x := x!hmi_right; LOOP + CASE t_env: gc_mark(x!env_data); x := x!env_outer; LOOP + CASE t_fun: FOR i = 0 TO (fun_ntracked OF x) - 1 DO + gc_mark((x+fun_data)!i) + ENDCASE + CASE t_atm: x := x!atm_value; LOOP + } + RETURN +} REPEAT + +LET gc_sweep() BE +{ LET last, this = nil, nil!nextptr + old_objects := 0 + UNTIL this = nil DO + { TEST gc_marked OF this THEN + { gc_marked OF this := 0 + old_objects := old_objects + 1 + last, this := this, this!nextptr + } ELSE + { LET tmp = this + this := this!nextptr + // writef("FREE : -> %8x (%8x)*n", tmp, tmp!1) + freevec(tmp) + last!nextptr := this + } + } +} + +LET gc(x) BE +{ IF new_objects > old_objects THEN + { // writef("Starting GC: ctr = %0d; last = %0d*n", alloc_ctr, alloc_last) + gc_mark(x) + gc_sweep() + new_objects := 0 + // writef("GC done: last = %0d*n", alloc_last) + } +} + +LET cons(first, rest) = VALOF +{ LET result = alloc_val(lst_sz) + type OF result := t_lst + result!lst_first := first + result!lst_rest := rest + RESULTIS result +} + +LET nth(lst, n) = VALOF +{ UNTIL n = 0 DO lst, n := lst!lst_rest, n - 1 + IF lst = empty THEN throwf("subscript out of range") + RESULTIS lst!lst_first +} + +LET as_lst(x) = VALOF SWITCHON type OF x INTO +{ CASE t_lst: RESULTIS x + CASE t_nil: RESULTIS empty + CASE t_vec: + { LET l = empty + FOR i = x!vec_len - 1 TO 0 BY -1 DO + l := cons((x+vec_data)!i, l) + RESULTIS l + } + DEFAULT: + throwf("cannot convert to list") +} + + +LET alloc_int(value) = VALOF +{ LET result = alloc_val(int_sz) + type OF result := t_int + result!int_value := value + RESULTIS result +} + +LET str_setlen(str, len) BE +{ str!str_len := len + (str + str_data) % 0 := len <= maxbcplstrlen -> len, maxbcplstrlen +} + +LET alloc_str(len) = VALOF +{ LET words = str_data + 1 + len / bytesperword + LET result = alloc_val(words) + result!(words - 1) := 0 // Make sure the unused part word at the end is 0. + type OF result := t_str + result!str_len := 0 + (result+str_data)%0 := 0 + RESULTIS result +} + +LET str_dup(val) = VALOF +{ LET new = alloc_str(val!str_len) + FOR i = 1 TO str_data + val!str_len / bytesperword DO + new!i := val!i + RESULTIS new +} + +LET str_substr(s, start, end) = VALOF +{ LET len = end - start + LET ss = alloc_str(len) + FOR i = 1 TO len DO + (ss + str_data) % i := (s + str_data) % (start + i - 1) + str_setlen(ss, len) + RESULTIS ss +} + +LET as_strtype(val, want_type) = VALOF +{ IF type OF val = want_type THEN RESULTIS val + val := str_dup(val) + type OF val := want_type + RESULTIS val +} + +LET as_str(val) = as_strtype(val, t_str) +LET as_sym(val) = as_strtype(val, t_sym) +LET as_kwd(val) = as_strtype(val, t_kwd) + +LET str_bcpl2mal(bcplstr) = VALOF +{ LET result = alloc_str(bcplstr%0) + result!str_len := bcplstr%0 + FOR i = 0 TO bcplstr%0 / bytesperword DO + result!(str_data + i) := bcplstr!i + RESULTIS result +} + +LET str_eq_const(val, bcplstr) = VALOF +{ UNLESS val!str_len = bcplstr%0 RESULTIS FALSE + FOR i = 0 TO bcplstr%0 / bytesperword DO + UNLESS val!(str_data + i) = bcplstr!i RESULTIS FALSE + RESULTIS TRUE +} + +LET equal_scalar(a, b) = VALOF +{ LET len = ? + UNLESS type OF a = type OF b RESULTIS FALSE + len := VALOF SWITCHON supertype OF a INTO + { CASE t_nil: RESULTIS 1 + CASE t_int: RESULTIS int_sz + CASE t_str: RESULTIS str_data + 1 + a!str_len / bytesperword + CASE t_hm0: RESULTIS hm0_sz + DEFAULT: throwf("incomparable value: %v", a) + } + // This is guaranteed not to walk off the end of b because any two mal + // values with different lengths will differ before the point where + // either of them ends. + FOR i = 1 TO len - 1 DO + UNLESS a!i = b!i RESULTIS FALSE + RESULTIS TRUE +} + +LET equal(a, b) = VALOF +{ UNLESS type OF a = type OF b RESULTIS equal_mixed(a, b) + SWITCHON type OF a INTO + { CASE t_lst: RESULTIS equal_lst(a, b) + CASE t_vec: RESULTIS equal_vec(a, b) + CASE t_hmi: RESULTIS equal_hmi(a, b) + CASE t_hmx: RESULTIS equal_hmx(a, b) + DEFAULT: RESULTIS equal_scalar(a, b) + } +} + +AND equal_mixed(a, b) = VALOF +{ // Mostly, values of different types are unequal. However mal has a + // special rule that a vector and a list are equal if they have the same + // contents. + IF type OF a = t_lst & type OF b = t_vec RESULTIS equal_lstvec(a, b) + IF type OF a = t_vec & type OF b = t_lst RESULTIS equal_lstvec(b, a) + RESULTIS FALSE +} + +AND equal_lst(a, b) = VALOF +{ IF a = b = empty RESULTIS TRUE + IF a = empty | b = empty RESULTIS FALSE + UNLESS equal(a!lst_first, b!lst_first) RESULTIS FALSE + a, b := a!lst_rest, b!lst_rest +} REPEAT + +AND equal_vec(a, b) = VALOF +{ UNLESS a!vec_len = b!vec_len RESULTIS FALSE + FOR i = 0 TO a!vec_len - 1 DO + UNLESS equal((a + vec_data)!i, (b + vec_data)!i) RESULTIS FALSE + RESULTIS TRUE +} + +AND equal_lstvec(l, v) = VALOF +{ FOR i = 0 TO v!vec_len - 1 DO + { IF l = empty RESULTIS FALSE + UNLESS equal(l!lst_first, (v + vec_data)!i) RESULTIS FALSE + l := l!lst_rest + } + RESULTIS l = empty +} + +// No need to compare the critical bit between nodes, since it's completely +// determined by the leaf nodes, which we will reach eventually. +AND equal_hmi(a, b) = equal(a!hmi_left, b!hmi_left) & + equal(a!hmi_right, b!hmi_right) + +AND equal_hmx(a, b) = equal(a!hmx_key, b!hmx_key) & + equal(a!hmx_value, b!hmx_value) + +LET alloc_vec(len) = VALOF +{ LET result = alloc_val(vec_data + len) + type OF result := t_vec + result!vec_len := len + FOR i = 0 TO len - 1 DO + (result + vec_data)!i := nil + RESULTIS result +} + +LET alloc_vecn(n, A, B, C, D) = VALOF +{ LET result = alloc_vec(n) + FOR i = 0 TO n - 1 DO + (result + vec_data)!i := (@A)!i + RESULTIS result +} + +LET alloc_fun(fn, sz, A, B, C) = VALOF +{ LET result = alloc_val(sz) + LET p = @A + type OF result := t_fun + result!fun_code := fn + FOR i = 0 TO sz - fun_data - 1 + result!(fun_data + i) := p!i + RESULTIS result +} + +LET alloc_hmx(key, value) = VALOF +{ LET result = alloc_val(hmx_sz) + type OF result := t_hmx + result!hmx_key, result!hmx_value := key, value + RESULTIS result +} + +LET alloc_hmi(critbit, left, right) = VALOF +{ LET result = alloc_val(hmi_sz) + type OF result := t_hmi + hmi_critbit OF result := critbit + result!hmi_left, result!hmi_right := left, right + RESULTIS result +} + +LET key_bit(key, bit) = VALOF +{ LET offset, shift = bit / BITSPERBCPLWORD, bit REM BITSPERBCPLWORD + // Skip over the first word because it's not part of the value. + offset := offset + 1 + RESULTIS key!offset >> (BITSPERBCPLWORD - 1 - shift) & 1 +} + +LET key_bitdiff(key1, key2) = VALOF +{ LET bit = 0 + WHILE key_bit(key1, bit) = key_bit(key2, bit) DO bit := bit + 1 + RESULTIS bit +} + +LET hm_pfx(pfx) BE + WHILE pfx > 0 DO + { writes(" ") + pfx := pfx - 1 + } + +LET hm_dumpi(map, pfx, lastbit) BE +{ hm_pfx(pfx) + TEST type OF map = t_hmi THEN + { writef("%8x: bit %n*n", map, hmi_critbit OF map) + hm_dumpi(map!hmi_left, pfx + 1, hmi_critbit OF map) + hm_dumpi(map!hmi_right, pfx + 1, hmi_critbit OF map) + } + ELSE + { LET p = map!hmx_key + 1 + writef("%8x:", map) + WHILE lastbit > 0 DO + { writef(" %8x", !p) + p := p + 1 + lastbit := lastbit - BITSPERBCPLWORD + } + writef(" v: %8x*n", map!hmx_value) + } +} + +LET hm_dump(map) BE +{ TEST map = empty_hashmap THEN writes("[empty]*n") + ELSE hm_dumpi(map, 0, 0) +} + +// hm_find finds the nearest entry in a non-empty hash-map to +// the key requested, and returns the entire entry. +LET hm_find(map, key) = VALOF +{ WHILE type OF map = t_hmi DO + map := key_bit(key, hmi_critbit OF map) -> map!hmi_right, map!hmi_left + RESULTIS map +} + +// Replace a known-present key in a non-empty hashmap. +LET hm_replace(map, key, value) = VALOF +{ LET left, right = ?, ? + IF type OF map = t_hmx RESULTIS alloc_hmx(key, value) + left, right := map!hmi_left, map!hmi_right + TEST key_bit(key, hmi_critbit OF map) THEN + right := hm_replace(map!hmi_right, key, value) + ELSE + left := hm_replace(map!hmi_left, key, value) + RESULTIS alloc_hmi(hmi_critbit OF map, left, right) +} + +// Add a known-absent key into a non-empty hashmap. It's known that the +// first bit where it differs from any existing key is 'bit'. +LET hm_insert(map, bit, key, value) = VALOF +{ LET left, right = ?, ? + IF type OF map = t_hmi & hmi_critbit OF map < bit THEN + { left, right := map!hmi_left, map!hmi_right + TEST key_bit(key, hmi_critbit OF map) THEN + right := hm_insert(map!hmi_right, bit, key, value) + ELSE + left := hm_insert(map!hmi_left, bit, key, value) + RESULTIS alloc_hmi(hmi_critbit OF map, left, right) + } + TEST key_bit(key, bit) THEN left, right := map, alloc_hmx(key, value) + ELSE right, left := map, alloc_hmx(key, value) + RESULTIS alloc_hmi(bit, left, right) +} + +LET hm_set(map, key, value) = VALOF +{ LET bit, nearest = ?, ? + IF compoundflag OF key = 1 THEN throwf("invalid hash-map key: %v", key) + IF map = empty_hashmap RESULTIS alloc_hmx(key, value) + nearest := hm_find(map, key) + IF equal(nearest!hmx_key, key) THEN RESULTIS hm_replace(map, key, value) + bit := key_bitdiff(key, nearest!hmx_key) + RESULTIS hm_insert(map, bit, key, value) +} + +LET hm_remove(map, key) = VALOF +{ IF compoundflag OF key = 1 THEN throwf("invalid hash-map key: %v", key) + IF map = empty_hashmap RESULTIS map + IF type OF map = t_hmx THEN + RESULTIS equal(map!hmx_key, key) -> empty_hashmap, map + TEST key_bit(key, hmi_critbit OF map) THEN + { LET child = hm_remove(map!hmi_right, key) + IF child = empty_hashmap RESULTIS map!hmi_left + RESULTIS alloc_hmi(hmi_critbit OF map, map!hmi_left, child) + } ELSE + { LET child = hm_remove(map!hmi_left, key) + IF child = empty_hashmap RESULTIS map!hmi_right + RESULTIS alloc_hmi(hmi_critbit OF map, child, hmi_right) + } +} + +LET hm_get(map, key) = VALOF +{ IF compoundflag OF key = 1 THEN throwf("invalid hash-map key: %v", key) + IF map = empty_hashmap RESULTIS nil + map := hm_find(map, key) + RESULTIS equal(map!hmx_key, key) -> map!hmx_value, nil +} + +LET hm_contains(map, key) = VALOF +{ IF compoundflag OF key = 1 THEN throwf("invalid hash-map key: %v", key) + IF map = empty_hashmap RESULTIS FALSE + map := hm_find(map, key) + RESULTIS equal(map!hmx_key, key) +} + +LET alloc_atm(value) = VALOF +{ LET result = alloc_val(atm_sz) + type OF result := t_atm + result!atm_value := value + RESULTIS result +} + +LET throw(val) BE +{ last_exception := val + longjump(catch_level, catch_label) +} diff --git a/runtest.py b/runtest.py index 2d32e85aae..0787b56bf7 100755 --- a/runtest.py +++ b/runtest.py @@ -245,7 +245,7 @@ def assert_prompt(runner, prompts, timeout): # Wait for the initial prompt try: - assert_prompt(r, ['[^\s()<>]+> '], args.start_timeout) + assert_prompt(r, ['[^\s()<>\d]+> '], args.start_timeout) except: _, exc, _ = sys.exc_info() log("\nException: %s" % repr(exc)) @@ -256,7 +256,7 @@ def assert_prompt(runner, prompts, timeout): if args.pre_eval: sys.stdout.write("RUNNING pre-eval: %s" % args.pre_eval) r.writeline(args.pre_eval) - assert_prompt(r, ['[^\s()<>]+> '], args.test_timeout) + assert_prompt(r, ['[^\s()<>\d]+> '], args.test_timeout) test_cnt = 0 pass_cnt = 0 @@ -293,7 +293,7 @@ class TestTimeout(Exception): r.writeline(t.form) try: test_cnt += 1 - res = r.read_to_prompt(['\r\n[^\s()<>]+> ', '\n[^\s()<>]+> '], + res = r.read_to_prompt(['\r\n[^\s()<>\d]+> ', '\n[^\s()<>\d]+> '], timeout=args.test_timeout) #print "%s,%s,%s" % (idx, repr(p.before), repr(p.after)) if (res == None):