commit ba9c6b8cadfd7b802403b6a2df129cad572cab58
parent 21cbd8312842f60c4ab99f36cedd0002d85fdac7
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Tue, 28 Apr 2026 09:41:38 -0700
scheme1: drop unused special forms (unless, define-values, case-lambda, letrec/letrec*, quasiquote)
cc.scm + prelude.scm don't use any of these. Removed handlers
(qq_walk, eval_quasiquote, eval_define_values, eval_letrec,
eval_unless, eval_case_lambda, apply_case_lambda), the CASELAMBDA
struct + HDR enum entry and its branches in apply / procedure? /
write_to_bv, the reader's `::quasiquote` branch and the `,@` peek
inside `::comma`, and the matching dispatch / intern / sym / name /
msg rows. Also dropped the define-values check in eval_body.
`unquote` (sym + name + intern + reader translation) stays — pmatch
recognizes `,ident` binder patterns by comparing against sym_unquote.
-454 lines from scheme1.P1pp.
Diffstat:
15 files changed, 13 insertions(+), 739 deletions(-)
diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp
@@ -13,7 +13,7 @@
%enum TAG { FIXNUM PAIR SYM HEAP IMM }
%enum IMM { FALSE TRUE NIL UNSPEC UNBOUND EOF }
-%enum HDR { BV CLOSURE PRIM TD REC CASELAMBDA MV }
+%enum HDR { BV CLOSURE PRIM TD REC MV }
# imm_val(idx) -> integer-expression for the tagged immediate at IMM index
# `idx`. Used both at %li sites (loaded into a register) and at $() emission
@@ -25,7 +25,6 @@
%struct SYMENT { name_ptr name_len global_val pad } # .SIZE = 32
%struct PRIM { hdr entry_w data } # .SIZE = 24
%struct CLOSURE { hdr params body env } # .SIZE = 32
-%struct CASELAMBDA { hdr clauses env pad } # .SIZE = 32
%struct TD { hdr name nfields fields } # .SIZE = 32
%struct BV { hdr data } # .SIZE = 16
%struct REC { hdr td } # .SIZE = 16 (header)
@@ -311,8 +310,6 @@
%beqz(a1, &::quote)
%addi(a1, a0, -44) ; ','
%beqz(a1, &::comma)
- %addi(a1, a0, -96) ; '`'
- %beqz(a1, &::quasiquote)
%addi(a1, a0, -34) ; '"'
%beqz(a1, &::string)
@@ -417,33 +414,14 @@
%tail(&cons)
::comma
- # Consume the leading ','. If the next byte is '@', this is `,@`
- # (unquote-splicing); otherwise it's `,` (unquote). Recurse into
- # parse_one for the inner datum and build the appropriate pair.
- # The comma sugar predates quasiquote -- it was added so pmatch
- # patterns could be written as `,ident`. Outside a quasiquote
- # template (and outside pmatch) `(unquote x)` still reaches eval as
- # an application of the unbound `unquote` and dies through the
- # standard unbound-variable path.
+ # Consume the leading ','; recurse into parse_one for the datum;
+ # build (unquote <datum>). The comma sugar exists so pmatch
+ # patterns can be written as `,ident`. Outside pmatch
+ # `(unquote x)` reaches eval as an application of the unbound
+ # `unquote` and dies through the standard unbound-variable path.
%lda_global(t0, t2, &readbuf_pos)
%addi(t0, t0, 1)
%st(t0, t2, 0)
- %ld_global(t1, &readbuf_len)
- %beq(t0, t1, &::comma_atom)
- %readbuf_byte(a0, t0)
- %addi(a1, a0, -64) ; '@'
- %bnez(a1, &::comma_atom)
- %addi(t0, t0, 1)
- %st(t0, t2, 0)
- %call(&parse_one)
- %li(a1, %imm_val(%IMM.NIL))
- %call(&cons)
- %ld_global(t0, &sym_unquote_splicing)
- %mov(a1, a0)
- %mov(a0, t0)
- %tail(&cons)
-
- ::comma_atom
%call(&parse_one)
%li(a1, %imm_val(%IMM.NIL))
%call(&cons)
@@ -452,23 +430,6 @@
%mov(a0, t0)
%tail(&cons)
- ::quasiquote
- # Consume the leading '`'; recurse into parse_one for the datum;
- # build (quasiquote <datum>). The evaluator implements one-level
- # template walking with `,` and `,@` substitution; nested
- # quasiquote forms are preserved literally rather than recursed
- # into.
- %lda_global(t0, t2, &readbuf_pos)
- %addi(t0, t0, 1)
- %st(t0, t2, 0)
- %call(&parse_one)
- %li(a1, %imm_val(%IMM.NIL))
- %call(&cons)
- %ld_global(t0, &sym_quasiquote)
- %mov(a1, a0)
- %mov(a0, t0)
- %tail(&cons)
-
::char_lit
# Cursor is already past '#\\'; parse_char scans the body and returns
# a tagged fixnum (the u8 char value).
@@ -1193,7 +1154,6 @@
%ldl(t0, expr)
%car(t0, t0) ; t0 = head
%dispatch_form(&sym_quote, &::do_quote)
- %dispatch_form(&sym_quasiquote, &::do_quasiquote)
%dispatch_form(&sym_if, &::do_if)
%dispatch_form(&sym_lambda, &::do_lambda)
%dispatch_form(&sym_define, &::do_define)
@@ -1201,21 +1161,16 @@
%dispatch_form(&sym_cond, &::do_cond)
%dispatch_form(&sym_let, &::do_let)
%dispatch_form(&sym_letstar, &::do_letstar)
- %dispatch_form(&sym_letrec, &::do_letrec)
- %dispatch_form(&sym_letrecstar, &::do_letrec)
%dispatch_form(&sym_let_values, &::do_let_values)
%dispatch_form(&sym_letstar_values, &::do_letstar_values)
- %dispatch_form(&sym_define_values, &::do_define_values)
%dispatch_form(&sym_and, &::do_and)
%dispatch_form(&sym_or, &::do_or)
%dispatch_form(&sym_when, &::do_when)
- %dispatch_form(&sym_unless, &::do_unless)
%dispatch_form(&sym_case, &::do_case)
%dispatch_form(&sym_setbang, &::do_setbang)
%dispatch_form(&sym_define_record_type, &::do_define_record_type)
%dispatch_form(&sym_pmatch, &::do_pmatch)
%dispatch_form(&sym_do, &::do_do)
- %dispatch_form(&sym_case_lambda, &::do_case_lambda)
# head = eval(car(expr), env)
%ldl(a0, expr)
@@ -1242,9 +1197,6 @@
%car(a0, a0)
%eret
- ::do_quasiquote
- %tail_to_handler(&eval_quasiquote)
-
::do_if
%tail_to_handler(&eval_if)
::do_lambda
@@ -1259,22 +1211,16 @@
%tail_to_handler(&eval_let)
::do_letstar
%tail_to_handler(&eval_letstar)
- ::do_letrec
- %tail_to_handler(&eval_letrec)
::do_let_values
%tail_to_handler(&eval_let_values)
::do_letstar_values
%tail_to_handler(&eval_letstar_values)
- ::do_define_values
- %tail_to_handler(&eval_define_values)
::do_and
%tail_to_handler(&eval_and)
::do_or
%tail_to_handler(&eval_or)
::do_when
%tail_to_handler(&eval_when)
- ::do_unless
- %tail_to_handler(&eval_unless)
::do_case
%tail_to_handler(&eval_case)
::do_setbang
@@ -1285,8 +1231,6 @@
%tail_to_handler(&eval_pmatch)
::do_do
%tail_to_handler(&eval_do)
- ::do_case_lambda
- %tail_to_handler(&eval_case_lambda)
})
# eval_args(args=a0, env=a1) -> evaluated args list (cons-built).
@@ -1339,149 +1283,6 @@
%ldl(a0, head)
})
-# qq_walk(t=a0, env=a1) -> result (a0). One-level quasiquote walker
-# (R7RS §4.2.8 minus the nested-template recursion). Atoms and any
-# `(quasiquote ...)` form are returned literally; an `(unquote x)` head
-# evaluates x; otherwise we walk the spine, splicing `(unquote-splicing
-# xs)` elements and recursing on every other element. Improper tails
-# are qq'd and stitched back onto the result.
-#
-# Locals:
-# t the template
-# env evaluation environment for `,` and `,@`
-# head accumulator head (NIL until first cell appended)
-# tail most recently appended cell
-# walk spine cursor (advances)
-# spliced inner cursor used during `,@` expansion
-%fn2(qq_walk, {t env head tail walk spliced}, {
- %stl(a0, t)
- %stl(a1, env)
- %li(t0, %imm_val(%IMM.NIL))
- %stl(t0, head)
- %stl(t0, tail)
-
- # Atom -> return as-is.
- %tagof(t0, a0)
- %li(t1, %TAG.PAIR)
- %bne(t0, t1, &::atom_ret)
-
- # (unquote x) at the top -> tail eval(cadr t, env).
- %ldl(t0, t)
- %car(t1, t0)
- %ld_global(t2, &sym_unquote)
- %beq(t1, t2, &::do_unquote)
- # Nested (quasiquote ...) -> literal; do not recurse.
- %ld_global(t2, &sym_quasiquote)
- %beq(t1, t2, &::atom_ret)
-
- # Walk the spine.
- %ldl(t0, t)
- %stl(t0, walk)
-
- ::loop
- %ldl(t0, walk)
- %if_nil(t1, t0, &::done)
- %tagof(t1, t0)
- %li(t2, %TAG.PAIR)
- %bne(t1, t2, &::improper)
-
- # elem = car(walk). Detect (unquote-splicing ...) shape.
- %car(a0, t0)
- %tagof(t1, a0)
- %li(t2, %TAG.PAIR)
- %bne(t1, t2, &::recurse_elem)
- %car(t1, a0)
- %ld_global(t2, &sym_unquote_splicing)
- %bne(t1, t2, &::recurse_elem)
-
- # spliced = eval(cadr elem, env)
- %cdr(a0, a0)
- %car(a0, a0)
- %ldl(a1, env)
- %call(&eval)
- %stl(a0, spliced)
-
- ::splice_loop
- %ldl(t0, spliced)
- %if_nil(t1, t0, &::splice_advance_walk)
- %tagof(t1, t0)
- %li(t2, %TAG.PAIR)
- %bne(t1, t2, &::splice_advance_walk)
- %car(a0, t0)
- %li(a1, %imm_val(%IMM.NIL))
- %call(&cons)
- %ldl(t0, head)
- %if_nil(t1, t0, &::splice_first)
- %ldl(t0, tail)
- %set_cdr(a0, t0)
- %stl(a0, tail)
- %b(&::splice_step)
- ::splice_first
- %stl(a0, head)
- %stl(a0, tail)
- ::splice_step
- %ldl(t0, spliced)
- %cdr(t0, t0)
- %stl(t0, spliced)
- %b(&::splice_loop)
-
- ::splice_advance_walk
- %ldl(t0, walk)
- %cdr(t0, t0)
- %stl(t0, walk)
- %b(&::loop)
-
- ::recurse_elem
- # new_elem = qq_walk(elem, env); elem already in a0.
- %ldl(a1, env)
- %call(&qq_walk)
- %li(a1, %imm_val(%IMM.NIL))
- %call(&cons)
- %ldl(t0, head)
- %if_nil(t1, t0, &::elem_first)
- %ldl(t0, tail)
- %set_cdr(a0, t0)
- %stl(a0, tail)
- %b(&::elem_step)
- ::elem_first
- %stl(a0, head)
- %stl(a0, tail)
- ::elem_step
- %ldl(t0, walk)
- %cdr(t0, t0)
- %stl(t0, walk)
- %b(&::loop)
-
- ::improper
- # walk holds a non-pair non-NIL cdr; qq it and stitch onto tail.
- %ldl(a0, walk)
- %ldl(a1, env)
- %call(&qq_walk)
- %ldl(t0, tail)
- %set_cdr(a0, t0)
-
- ::done
- %ldl(a0, head)
- %eret
-
- ::atom_ret
- %ldl(a0, t)
- %eret
-
- ::do_unquote
- %ldl(t0, t)
- %cdr(t0, t0)
- %car(a0, t0)
- %ldl(a1, env)
- %tail(&eval)
-})
-
-# eval_quasiquote(rest=a0, env=a1) -> result (a0). rest = (template . _);
-# tail-walks the template through qq_walk.
-%fn(eval_quasiquote, 0, {
- %car(a0, a0)
- %tail(&qq_walk)
-})
# apply(fn=a0, args=a1) -> result (a0)
#
@@ -1501,8 +1302,6 @@
%beq(t0, t1, &::prim)
%li(t1, %HDR.CLOSURE)
%beq(t0, t1, &::closure)
- %li(t1, %HDR.CASELAMBDA)
- %beq(t0, t1, &::case_lambda)
::not_proc
%die(msg_not_proc)
@@ -1541,12 +1340,6 @@
%ldl(a0, body)
%tail(&eval_body)
- ::case_lambda
- # apply_case_lambda(args, obj). args already in `args` slot; the obj
- # is still in a0.
- %mov(a1, a0)
- %ldl(a0, args)
- %tail(&apply_case_lambda)
})
# =========================================================================
@@ -1561,8 +1354,6 @@
%fn(intern_special_forms, 0, {
%intern_form(&name_quote, 5, &sym_quote)
- %intern_form(&name_quasiquote, 10, &sym_quasiquote)
- %intern_form(&name_unquote_splicing, 16, &sym_unquote_splicing)
%intern_form(&name_if, 2, &sym_if)
%intern_form(&name_lambda, 6, &sym_lambda)
%intern_form(&name_define, 6, &sym_define)
@@ -1572,21 +1363,16 @@
%intern_form(&name_arrow, 2, &sym_arrow)
%intern_form(&name_let, 3, &sym_let)
%intern_form(&name_letstar, 4, &sym_letstar)
- %intern_form(&name_letrec, 6, &sym_letrec)
- %intern_form(&name_letrecstar, 7, &sym_letrecstar)
%intern_form(&name_let_values, 10, &sym_let_values)
%intern_form(&name_letstar_values, 11, &sym_letstar_values)
- %intern_form(&name_define_values, 13, &sym_define_values)
%intern_form(&name_and, 3, &sym_and)
%intern_form(&name_or, 2, &sym_or)
%intern_form(&name_when, 4, &sym_when)
- %intern_form(&name_unless, 6, &sym_unless)
%intern_form(&name_case, 4, &sym_case)
%intern_form(&name_setbang, 4, &sym_setbang)
%intern_form(&name_define_record_type, 18, &sym_define_record_type)
%intern_form(&name_pmatch, 6, &sym_pmatch)
%intern_form(&name_do, 2, &sym_do)
- %intern_form(&name_case_lambda, 11, &sym_case_lambda)
%intern_form(&name_unquote, 7, &sym_unquote)
%intern_form(&name_guard, 5, &sym_guard)
%intern_form(&name_underscore, 1, &sym_underscore)
@@ -1723,70 +1509,6 @@
%li(a0, %imm_val(%IMM.UNSPEC))
})
-# eval_define_values(rest=a0, env=a1) -> UNSPEC (a0).
-# Top-level only. rest = (formals value-expr). Evaluates value-expr,
-# normalizes its result via mv_to_list, then walks formals and the value
-# list in lockstep, binding each name in the global symbol table. A SYM
-# tail (or bare-SYM formals) binds the remaining values list as one name.
-# Internal define-values is rejected by eval_body alongside `define`.
-#
-# Locals:
-# rest
-# env
-# vals (remaining values list; advances each iteration)
-# formals (remaining formals; advances each iteration)
-%fn2(eval_define_values, {rest env vals formals}, {
- %stl(a0, rest)
- %stl(a1, env)
-
- # value = eval(cadr(rest), env)
- %cdr(t0, a0)
- %car(a0, t0)
- %ldl(a1, env)
- %call(&eval)
-
- # vals = mv_to_list(value)
- %call(&mv_to_list)
- %stl(a0, vals)
-
- %ldl(t0, rest)
- %car(t0, t0) ; formals (initial)
- %stl(t0, formals)
-
- ::loop
- %ldl(t0, formals)
- %tagof(t1, t0)
- %li(t2, %TAG.PAIR)
- %beq(t1, t2, &::pair_form)
- %li(t2, %TAG.SYM)
- %beq(t1, t2, &::rest_bind)
- %b(&::done)
-
- ::pair_form
- %ldl(t0, formals)
- %car(t0, t0) ; name
- %ldl(a0, vals)
- %car(a0, a0) ; value
- %bind_global_from_t0()
-
- %ldl(t0, formals)
- %cdr(t0, t0)
- %stl(t0, formals)
- %ldl(t0, vals)
- %cdr(t0, t0)
- %stl(t0, vals)
- %b(&::loop)
-
- ::rest_bind
- # Bare-SYM (or dotted-tail) formal: bind remaining values list as one.
- %ldl(t0, formals)
- %ldl(a0, vals)
- %bind_global_from_t0()
-
- ::done
- %li(a0, %imm_val(%IMM.UNSPEC))
-})
-
# eval_setbang(rest=a0, env=a1) -> UNSPEC (a0).
# rest = (sym value-expr). Evaluates value-expr in env, then walks the
# env alist looking for a binding cell whose car is the target sym;
@@ -2037,85 +1759,6 @@
%tail(&eval_body)
})
-# eval_letrec(rest=a0, env=a1) -> value (a0).
-# Two-phase. Phase 1: pre-bind every name to UNSPEC in the new env so
-# inits can reference each other. Phase 2: evaluate each init in the new
-# env and patch the matching binding's cdr (linear-scan lookup is fine
-# here -- bindings are typically ≤ a handful).
-#
-# Locals:
-# rest
-# env_orig
-# walk
-# new_env
-%fn2(eval_letrec, {rest env_orig walk new_env}, {
- %stl(a0, rest)
- %stl(a1, env_orig)
-
- %ldl(t0, rest)
- %car(t0, t0)
- %stl(t0, walk)
- %ldl(t0, env_orig)
- %stl(t0, new_env)
-
- ::phase1
- %ldl(t0, walk)
- %if_nil(t1, t0, &::p1_done)
-
- %car(t1, t0)
- %car(t2, t1) ; name
- %mov(a0, t2)
- %li(a1, %imm_val(%IMM.UNSPEC))
- %call(&cons)
- %ldl(a1, new_env)
- %call(&cons)
- %stl(a0, new_env)
-
- %advance_walk(16)
- %b(&::phase1)
-
- ::p1_done
- %ldl(t0, rest)
- %car(t0, t0)
- %stl(t0, walk) ; reset walk
-
- ::phase2
- %ldl(t0, walk)
- %if_nil(t1, t0, &::p2_done)
-
- %car(t1, t0)
- %cdr(t2, t1)
- %car(t2, t2) ; init
- %mov(a0, t2)
- %ldl(a1, new_env)
- %call(&eval) ; val in a0
-
- %ldl(t0, walk)
- %car(t1, t0)
- %car(t2, t1) ; name (in t2)
-
- %ldl(t1, new_env)
- ::scan
- %car(a1, t1)
- %car(a2, a1)
- %beq(a2, t2, &::found)
- %cdr(t1, t1)
- %b(&::scan)
-
- ::found
- %car(a1, t1)
- %set_cdr(a0, a1) ; set-cdr! binding val
-
- %advance_walk(16)
- %b(&::phase2)
-
- ::p2_done
- %ldl(a0, rest)
- %cdr(a0, a0)
- %ldl(a1, new_env)
- %tail(&eval_body)
-})
-
# eval_let_values(rest=a0, env=a1) -> value (a0).
# rest = (((formals init) ...) body...). Each init is evaluated in the
# OUTER env; mv_to_list normalizes its result so bind_params can drive
@@ -2337,31 +1980,6 @@
%li(a0, %imm_val(%IMM.UNSPEC))
})
-# eval_unless(rest=a0, env=a1) -> value (a0).
-# Mirror of eval_when: tail-eval body iff test is #f, else UNSPEC.
-#
-# Locals:
-# rest
-# env
-%fn2(eval_unless, {rest env}, {
- %stl(a0, rest)
- %stl(a1, env)
-
- %car(a0, a0) ; test
- %call(&eval)
-
- %li(t0, %imm_val(%IMM.FALSE))
- %bne(a0, t0, &::skip)
-
- %ldl(a0, rest)
- %cdr(a0, a0) ; body
- %ldl(a1, env)
- %tail(&eval_body)
-
- ::skip
- %li(a0, %imm_val(%IMM.UNSPEC))
-})
-
# eval_case(rest=a0, env=a1) -> value (a0).
# rest is (key-expr clause...). The key is evaluated once; clauses are
# tried in order. Clause shape:
@@ -2770,144 +2388,6 @@
%b(&::update_loop)
})
-# eval_case_lambda(rest=a0, env=a1) -> case-lambda object (a0).
-# rest = ((formals body...) ...). Allocates a 32-byte HDR.CASELAMBDA
-# heap object holding the clauses list and the captured env. apply()
-# dispatches by walking clauses and matching the first whose formals
-# admit the argument count.
-#
-# Locals:
-# rest
-# env
-# obj
-%fn2(eval_case_lambda, {rest env obj}, {
- %stl(a0, rest)
- %stl(a1, env)
-
- %li(a0, 32)
- %li(a1, %HDR.CASELAMBDA)
- %call(&alloc_hdr)
- %stl(a0, obj)
-
- # obj.clauses = rest.
- %ldl(t1, rest)
- %ldl(t0, obj)
- %heap_st(t1, t0, %CASELAMBDA.clauses)
-
- # obj.env = env.
- %ldl(t1, env)
- %heap_st(t1, t0, %CASELAMBDA.env)
-
- %ldl(a0, obj)
-})
-
-# apply_case_lambda(args=a0, obj=a1) -> result.
-# Walks obj's clauses; the first whose formals shape admits the given
-# argument count is selected. Match rules:
-# formals = NIL -> arglen == 0
-# formals = SYM (rest) -> always matches
-# formals = (a b ...) -> arglen == count(formals)
-# formals = (a b ... . rest) -> arglen >= count(proper-prefix)
-# On match: bind_params(formals, args, captured_env) -> new_env;
-# tail-eval body in new_env. No-match dies with msg_case_lambda_no_match.
-#
-# Locals:
-# args
-# obj
-# arglen
-# clauses (advances)
-# env_capt (captured env from obj)
-# formals (current clause's formals; saved across bind_params)
-# body (current clause's body; saved across bind_params)
-%fn2(apply_case_lambda, {args obj arglen clauses env_capt formals body}, {
- %stl(a0, args)
- %stl(a1, obj)
-
- %ldl(a0, args)
- %call(&list_length)
- %stl(a0, arglen)
-
- %ldl(t0, obj)
- %heap_ld(t1, t0, %CASELAMBDA.clauses)
- %stl(t1, clauses)
- %heap_ld(t1, t0, %CASELAMBDA.env)
- %stl(t1, env_capt)
-
- ::loop
- %ldl(t0, clauses)
- %if_nil(t1, t0, &::no_match)
-
- %car(t1, t0) ; clause
- %car(t2, t1) ; formals
- %stl(t2, formals)
- %cdr(t2, t1) ; body
- %stl(t2, body)
-
- %ldl(t0, formals)
- %tagof(t1, t0)
-
- # SYM formals: unconditional rest, always matches.
- %li(t2, %TAG.SYM)
- %beq(t1, t2, &::matched)
-
- # PAIR formals: count proper prefix, inspect terminator.
- %li(t2, %TAG.PAIR)
- %beq(t1, t2, &::pair_walk)
-
- # Otherwise (NIL or other immediate): match iff arglen == 0.
- %ldl(t0, arglen)
- %beqz(t0, &::matched)
- %b(&::next)
-
- ::pair_walk
- %li(t2, 0) ; required count
- %ldl(t0, formals)
- ::pcount
- %tagof(t1, t0)
- %li(a3, %TAG.PAIR)
- %bne(t1, a3, &::pcount_done)
- %addi(t2, t2, 1)
- %cdr(t0, t0)
- %b(&::pcount)
-
- ::pcount_done
- # cursor (t0) is NIL (proper) or SYM (improper).
- %tagof(t1, t0)
- %li(a3, %TAG.SYM)
- %beq(t1, a3, &::improper)
-
- # Proper formals: arglen must equal required.
- %ldl(a3, arglen)
- %beq(a3, t2, &::matched)
- %b(&::next)
-
- ::improper
- # Improper formals: arglen must be >= required.
- # `arglen >= required` is `!(arglen < required)`.
- %ldl(a3, arglen)
- %blt(a3, t2, &::next)
- %b(&::matched)
-
- ::next
- %ldl(t0, clauses)
- %cdr(t0, t0)
- %stl(t0, clauses)
- %b(&::loop)
-
- ::matched
- %ldl(a0, formals)
- %ldl(a1, args)
- %ldl(a2, env_capt)
- %call(&bind_params)
-
- %mov(a1, a0)
- %ldl(a0, body)
- %tail(&eval_body)
-
- ::no_match
- %die(msg_case_lambda_no_match)
-})
-
# pmatch_match(pat=a0, subj=a1, env=a2) -> (env=a0, ok=a1)
#
# Walks pat and subj structurally. On success returns the (possibly
@@ -3342,9 +2822,8 @@
%stl(a0, body)
%stl(a1, env)
- # Reject internal `define` / `define-values`. Detect (define ...) or
- # (define-values ...) at the head of any form before dispatching to
- # eval; both are top-level-only.
+ # Reject internal `define`. Detect (define ...) at the head of any
+ # form before dispatching to eval; top-level-only.
%car(t0, a0) ; form
%tagof(t1, t0)
%li(t2, %TAG.PAIR)
@@ -3352,8 +2831,6 @@
%car(t1, t0) ; head sym
%ld_global(t2, &sym_define)
%beq(t1, t2, &::internal_define)
- %ld_global(t2, &sym_define_values)
- %beq(t1, t2, &::internal_define)
::not_define
# If cdr(body) is NIL, body's car is the last form.
@@ -4065,8 +3542,6 @@
%beq(t1, t2, &::yes)
%li(t2, %HDR.PRIM)
%beq(t1, t2, &::yes)
- %li(t2, %HDR.CASELAMBDA)
- %beq(t1, t2, &::yes)
%b(&::end)
::yes
%li(a0, %imm_val(%IMM.TRUE))
@@ -5475,8 +4950,6 @@
%beq(t0, t1, &::heap_bv)
%li(t1, %HDR.CLOSURE)
%beq(t0, t1, &::heap_closure)
- %li(t1, %HDR.CASELAMBDA)
- %beq(t0, t1, &::heap_closure)
%li(t1, %HDR.PRIM)
%beq(t0, t1, &::heap_prim)
%li(t1, %HDR.TD)
@@ -6353,24 +5826,17 @@
:name_arrow "=>" '0000000000'
:name_let "let" '00000000'
:name_letstar "let*" '000000'
-:name_letrec "letrec" '00'
-:name_letrecstar "letrec*"
:name_let_values "let-values" '0000000000'
:name_letstar_values "let*-values" '00000000'
-:name_define_values "define-values" '0000'
:name_and "and" '00000000'
:name_or "or" '0000000000'
:name_when "when" '000000'
-:name_unless "unless" '00'
:name_case "case" '000000'
:name_setbang "set!" '000000'
:name_define_record_type "define-record-type" '0000000000'
:name_pmatch "pmatch" '00'
:name_do "do" '0000000000'
-:name_case_lambda "case-lambda" '00000000'
:name_unquote "unquote"
-:name_quasiquote "quasiquote" '0000000000'
-:name_unquote_splicing "unquote-splicing" '00000000000000'
:name_guard "guard" '0000'
:name_underscore "_" '000000000000'
:name_dollar "$" '000000000000'
@@ -6558,10 +6024,9 @@
:msg_bad_char "scheme1: bad #\\ character literal" '0a' '00000000' ;; 34+1+1+4=40
:msg_bad_number "scheme1: bad number literal" '0a' '000000' ;; 27+1+1+3=32
:msg_bad_ident "scheme1: bad identifier" '0a' '00000000000000' ;; 23+1+1+7=32
-:msg_internal_define "scheme1: internal define is not supported (use letrec)" '0a' ;; 54+1+1+0=56
+:msg_internal_define "scheme1: internal define is not supported" '0a' '0000000000' ;; 41+1+1+5=48
:msg_pmatch_no_match "scheme1: pmatch: no clause matched" '0a' '00000000' ;; 34+1+1+4=40
:msg_bad_unquote_pattern "scheme1: pmatch: malformed ,-pattern" '0a' '0000' ;; 36+1+1+2=40
-:msg_case_lambda_no_match "scheme1: case-lambda: no clause matched arity" '0a' '00' ;; 45+1+1+1=48
:name_ch_tab "tab" '00000000' ;; 3+1+4=8
:name_ch_null "null" '000000' ;; 4+1+3=8
@@ -6666,24 +6131,17 @@
:sym_arrow $(0)
:sym_let $(0)
:sym_letstar $(0)
-:sym_letrec $(0)
-:sym_letrecstar $(0)
:sym_let_values $(0)
:sym_letstar_values $(0)
-:sym_define_values $(0)
:sym_and $(0)
:sym_or $(0)
:sym_when $(0)
-:sym_unless $(0)
:sym_case $(0)
:sym_setbang $(0)
:sym_define_record_type $(0)
:sym_pmatch $(0)
:sym_do $(0)
-:sym_case_lambda $(0)
:sym_unquote $(0)
-:sym_quasiquote $(0)
-:sym_unquote_splicing $(0)
:sym_guard $(0)
:sym_underscore $(0)
:sym_dollar $(0)
diff --git a/tests/scheme1/020-letrec.expected-exit b/tests/scheme1/020-letrec.expected-exit
@@ -1 +0,0 @@
-4
diff --git a/tests/scheme1/020-letrec.scm b/tests/scheme1/020-letrec.scm
@@ -1,25 +0,0 @@
-; letrec / letrec*: local recursive bindings. letrec* is an alias of
-; letrec in scheme1 (eval_letrec already evaluates inits left-to-right);
-; the R7RS guarantee letrec* adds — later inits may reference earlier
-; ones — is exercised below.
-
-;; --- letrec: classic recursive factorial ---------------------------
-(if (= 120 (letrec ((fact (lambda (n)
- (if (= n 0) 1 (* n (fact (- n 1)))))))
- (fact 5)))
- 0 (sys-exit 1))
-
-;; --- letrec* accepts the same shape and value ---------------------
-(if (= 120 (letrec* ((fact (lambda (n)
- (if (= n 0) 1 (* n (fact (- n 1)))))))
- (fact 5)))
- 0 (sys-exit 2))
-
-;; --- letrec*: later inits reference earlier ones -------------------
-;; y depends on x; z depends on both. + is 2-arg in scheme1, so each
-;; init uses pairwise sums.
-(if (= 6 (letrec* ((x 1) (y (+ x 2)) (z (+ y x)))
- (+ z 2)))
- 0 (sys-exit 3))
-
-(sys-exit 4)
diff --git a/tests/scheme1/021-letrec-recursion.expected-exit b/tests/scheme1/021-letrec-recursion.expected-exit
@@ -1 +0,0 @@
-7
diff --git a/tests/scheme1/021-letrec-recursion.scm b/tests/scheme1/021-letrec-recursion.scm
@@ -1,3 +0,0 @@
-; letrec actually exercises recursion: f(2) recurses to f(#f), which
-; takes the else branch and exits 7.
-(sys-exit (letrec ((f (lambda (n) (if n (f #f) 7)))) (f 2)))
diff --git a/tests/scheme1/085-internal-define-error.expected b/tests/scheme1/085-internal-define-error.expected
@@ -1 +1 @@
-scheme1: internal define is not supported (use letrec)
+scheme1: internal define is not supported
diff --git a/tests/scheme1/085-internal-define-error.scm b/tests/scheme1/085-internal-define-error.scm
@@ -1,6 +1,6 @@
; Internal `define` -- inside any non-empty lexical env (lambda body,
-; let body, letrec body) -- is forbidden in this Scheme. eval_define
-; rejects with a clear message and exits 1 via runtime_error. Use
-; letrec for local recursive bindings.
+; let body) -- is forbidden in this Scheme. eval_define rejects with
+; a clear message and exits 1 via runtime_error. Use a top-level
+; define or named-let for local recursion.
((lambda () (define x 1) x))
(sys-exit 0)
diff --git a/tests/scheme1/095-unless.expected-exit b/tests/scheme1/095-unless.expected-exit
@@ -1 +0,0 @@
-17
diff --git a/tests/scheme1/095-unless.scm b/tests/scheme1/095-unless.scm
@@ -1,24 +0,0 @@
-; (unless test body...) -- mirror of `when`. Body runs (and last value
-; is returned) when test is #f; otherwise UNSPEC.
-
-;; --- Falsy test: body runs, last form is the value -------------------
-(if (= 5 (unless #f 1 2 3 4 5)) 0 (sys-exit 1))
-
-;; --- Truthy test: body skipped; result is UNSPEC ---------------------
-(if (eq? (unless #t (sys-exit 99)) (unless 0 42)) 0 (sys-exit 2))
-(if (not (eq? (unless #t 1) #t)) 0 (sys-exit 3))
-(if (not (eq? (unless #t 1) #f)) 0 (sys-exit 4))
-(if (not (eq? (unless #t 1) '())) 0 (sys-exit 5))
-
-;; --- Body side-effects fire only when test is falsy ------------------
-(define counter 0)
-(unless #t (set! counter 100))
-(if (= counter 0) 0 (sys-exit 6))
-(unless #f (set! counter (+ counter 1)) (set! counter (+ counter 2)))
-(if (= counter 3) 0 (sys-exit 7))
-
-;; --- Any non-#f counts as true (so body is skipped) ------------------
-(if (eq? (unless 0 1) (unless #t 1)) 0 (sys-exit 8))
-(if (eq? (unless '() 1) (unless #t 1)) 0 (sys-exit 9))
-
-(sys-exit 17)
diff --git a/tests/scheme1/106-case-lambda.expected-exit b/tests/scheme1/106-case-lambda.expected-exit
@@ -1 +0,0 @@
-42
diff --git a/tests/scheme1/106-case-lambda.scm b/tests/scheme1/106-case-lambda.scm
@@ -1,47 +0,0 @@
-; (case-lambda (formals body...) ...) -- pick the first clause whose
-; formals match the call's arity. Formals follow the same shape as
-; lambda: (a b), (), (a b . rest), or rest-symbol.
-
-;; --- Plain arity dispatch -----------------------------------------------
-(define f (case-lambda
- (() 100)
- ((x) (+ x 1))
- ((x y) (* x y))))
-(if (= 100 (f)) 0 (sys-exit 1))
-(if (= 4 (f 3)) 0 (sys-exit 2))
-(if (= 12 (f 3 4)) 0 (sys-exit 3))
-
-;; --- First matching clause wins ------------------------------------------
-(define g (case-lambda
- ((x) 'first)
- ((x) 'second)))
-(if (eq? 'first (g 7)) 0 (sys-exit 4))
-
-;; --- Rest argument clause: variadic match --------------------------------
-(define h (case-lambda
- (() 'none)
- ((x) (list 'one x))
- (xs (cons 'many xs))))
-(if (eq? 'none (h)) 0 (sys-exit 5))
-(if (equal? (h 9) (list 'one 9)) 0 (sys-exit 6))
-(if (equal? (h 1 2 3) (cons 'many (list 1 2 3))) 0 (sys-exit 7))
-
-;; --- Improper formals: (a . rest) ----------------------------------------
-(define k (case-lambda
- ((a) 'lone)
- ((a . rest) (cons a rest))))
-(if (eq? 'lone (k 5)) 0 (sys-exit 8))
-(if (equal? (k 1 2 3) (list 1 2 3)) 0 (sys-exit 9))
-
-;; --- Closes over the enclosing environment -------------------------------
-(define base 10)
-(define add (case-lambda
- ((x) (+ base x))
- ((x y) (+ (+ base x) y))))
-(if (= 11 (add 1)) 0 (sys-exit 10))
-(if (= 13 (add 1 2)) 0 (sys-exit 11))
-
-;; --- Higher-order: case-lambda result is a procedure --------------------
-(if (procedure? f) 0 (sys-exit 12))
-
-(sys-exit 42)
diff --git a/tests/scheme1/107-quasiquote.expected-exit b/tests/scheme1/107-quasiquote.expected-exit
@@ -1 +0,0 @@
-0
diff --git a/tests/scheme1/107-quasiquote.scm b/tests/scheme1/107-quasiquote.scm
@@ -1,56 +0,0 @@
-; One-level quasiquote: backtick reads as (quasiquote ...); inside that
-; template, (unquote x) splices a single evaluated value, and
-; (unquote-splicing xs) splices the elements of xs in place. Atoms in
-; the template are returned literally; nested quasiquote forms are not
-; supported -- we don't recurse into them, so a `(quasiquote ...) form
-; sitting inside the template is preserved as-is.
-
-;; --- Atom template: returns the atom -------------------------------------
-(if (= 7 `7) 0 (sys-exit 1))
-(if (eq? 'foo `foo) 0 (sys-exit 2))
-(if (equal? '() `()) 0 (sys-exit 3))
-
-;; --- All-literal list template ------------------------------------------
-(if (equal? (list 1 2 3) `(1 2 3)) 0 (sys-exit 4))
-(if (equal? '(a b c) `(a b c)) 0 (sys-exit 5))
-
-;; --- ,x evaluates one element in place ----------------------------------
-(define x 10)
-(if (equal? (list 1 10 3) `(1 ,x 3)) 0 (sys-exit 6))
-(if (equal? (list 'a 11 'b) `(a ,(+ x 1) b)) 0 (sys-exit 7))
-
-;; --- ,x at head and tail positions --------------------------------------
-(if (equal? (list 10 'b) `(,x b)) 0 (sys-exit 8))
-(if (equal? (list 'a 10) `(a ,x)) 0 (sys-exit 9))
-
-;; --- ,@xs splices a list in place ---------------------------------------
-(define xs (list 2 3 4))
-(if (equal? (list 1 2 3 4 5) `(1 ,@xs 5)) 0 (sys-exit 10))
-
-;; --- ,@ at the head of the list -----------------------------------------
-(if (equal? (list 2 3 4 'tail) `(,@xs tail)) 0 (sys-exit 11))
-
-;; --- ,@ at the tail of the list -----------------------------------------
-(if (equal? (list 'head 2 3 4) `(head ,@xs)) 0 (sys-exit 12))
-
-;; --- ,@'() splices nothing ----------------------------------------------
-(if (equal? (list 'a 'b) `(a ,@'() b)) 0 (sys-exit 13))
-
-;; --- Mixed: literals, ,, ,@ in one template -----------------------------
-(if (equal? (list 'h 10 2 3 4 'mid 11 't)
- `(h ,x ,@xs mid ,(+ x 1) t))
- 0 (sys-exit 14))
-
-;; --- Nested-list template (no ,) is preserved literally -----------------
-(if (equal? '((a b) (c d)) `((a b) (c d))) 0 (sys-exit 15))
-
-;; --- , inside a nested list still evaluates at this depth ---------------
-(if (equal? (list (list 1 10) 'k) `((1 ,x) k)) 0 (sys-exit 16))
-
-;; --- ,@ inside a nested list splices into that nested list --------------
-(if (equal? (list (list 1 2 3 4) 'k) `((1 ,@xs) k)) 0 (sys-exit 17))
-
-;; --- (quasiquote x) prefix form parses identically to `x ----------------
-(if (equal? (list 1 10 3) (quasiquote (1 (unquote x) 3))) 0 (sys-exit 18))
-
-(sys-exit 0)
diff --git a/tests/scheme1/114-define-values.expected-exit b/tests/scheme1/114-define-values.expected-exit
@@ -1 +0,0 @@
-0
diff --git a/tests/scheme1/114-define-values.scm b/tests/scheme1/114-define-values.scm
@@ -1,23 +0,0 @@
-; define-values: bind multiple top-level names from a values producer.
-
-(define-values (a b c) (values 1 2 3))
-(if (= 6 (+ a b c)) 0 (sys-exit 1))
-
-; Single-name formals work with non-values value-expr.
-(define-values (x) 42)
-(if (= 42 x) 0 (sys-exit 2))
-
-; Variadic formal collects all yielded values.
-(define-values rest (values 10 20 30))
-(if (equal? (list 10 20 30) rest) 0 (sys-exit 3))
-
-; Dotted formal: head + tail.
-(define-values (h . t) (values 1 2 3))
-(if (= 1 h) 0 (sys-exit 4))
-(if (equal? (list 2 3) t) 0 (sys-exit 5))
-
-; Subsequent define-values reassigns globally.
-(define-values (a b c) (values 100 200 300))
-(if (= 600 (+ a b c)) 0 (sys-exit 6))
-
-(sys-exit 0)
