Zander671/glisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Lexical jumps

Browse Source
This commit is contained in:
Zander671
2026-09-05 00:58:11 -07:00
parent 8024bcfee3
commit 956297335d
13 changed files with 164 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lisp/kernel.gl
+3 -4
View File
@@ -1,7 +1,6 @@
;; -*- mode: lisp-data -*-
(fset 'test (cons 'macro (lambda (x) (declare (name test)) (list 'princ x))))
(prin1 (macroexpand-all '(lambda () (test x))
'((test . (lambda (x) (test x))))))
(prin1 (let ((l (block 'c (lambda () (return-from 'c 3)))))
(block 'c
(funcall l))))
(write-byte ?\n)
src/base.c
+1
View File
@@ -65,6 +65,7 @@ DEFINE_SYMBOL(nil, "nil");
DEFINE_SYMBOL(t, "t");
DEFINE_SYMBOL(unbound, "unbound");
DEFVAR(lexical_environment, "lexical-environment", "", Qnil);
DEFINE_SYMBOL(lexical_tags, "lexical-tags");
DEFUN(id, "id", (LispVal * obj), "(id)", "") {
// TODO not all values are handled here
src/base.h
+22
View File
@@ -281,6 +281,8 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
LispVal *F##cname cargs
#define DEFSPECIAL(cname, lisp_name, cargs, lisp_args, doc) \
DEFUN(cname, lisp_name, cargs, lisp_args, doc)
#define DEFSPECIAL_NOINTERN(cname, lisp_name, cargs, lisp_args, doc) \
DEFUN(cname, lisp_name, cargs, lisp_args, doc)
#define DEFINE_CONDITION_CLASS(cname, parent_cname) \
LispVal **internal_Q##cname##_parent_condition_class = &Q##parent_cname
@@ -292,6 +294,14 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
((LispSymbol *) Q##cname)->value_type = SYMBOL_NORMAL; \
lisp_gc_register_static_object(Q##cname); \
}
#define REGISTER_GLOBAL_SYMBOL_NOINTERN(cname) \
{ \
Q##cname = Fmake_symbol(make_lisp_string(internal_Q##cname##_name, \
internal_Q##cname##_name_len, \
false, false)); \
((LispSymbol *) Q##cname)->value_type = SYMBOL_NORMAL; \
lisp_gc_register_static_object(Q##cname); \
}
#define REGISTER_GLOBAL_VARIABLE(cname) \
REGISTER_GLOBAL_SYMBOL(cname); \
{ \
@@ -303,12 +313,22 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
#define REGISTER_GLOBAL_FUNCTION(cname) \
{ \
REGISTER_GLOBAL_SYMBOL(cname); \
((LispSymbol *) Q##cname)->flags |= SYMBOL_CONST_FUNCTION; \
((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
}
#define REGISTER_GLOBAL_SPECIAL_NOINTERN(cname) \
{ \
REGISTER_GLOBAL_SYMBOL_NOINTERN(cname); \
((LispSymbol *) Q##cname)->flags |= SYMBOL_CONST_FUNCTION; \
((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
((LispFunction *) ((LispSymbol *) Q##cname)->function) \
->impl.native.no_eval_args = true; \
}
#define REGISTER_GLOBAL_SPECIAL(cname) \
{ \
REGISTER_GLOBAL_SYMBOL(cname); \
((LispSymbol *) Q##cname)->flags |= SYMBOL_CONST_FUNCTION; \
((LispSymbol *) Q##cname)->function = BUILTIN_FUNCTION_OBJ(cname); \
((LispFunction *) ((LispSymbol *) Q##cname)->function) \
->impl.native.no_eval_args = true; \
@@ -321,8 +341,10 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
DECLARE_SYMBOL(nil);
DECLARE_SYMBOL(t);
// these are uninterned
DECLARE_SYMBOL(unbound);
DECLARE_VARIABLE(lexical_environment);
DECLARE_VARIABLE(lexical_tags);
extern LispVal *Vlexical_environment;
src/function.c
+2 -2
View File
@@ -373,7 +373,7 @@ static ALWAYS_INLINE void push_optional_argument_to_lexenv(LispVal *spec,
static ALWAYS_INLINE void
push_missing_optional_argument_to_lexenv(LispVal *spec) {
new_lexical_variable(XCAR(spec), Feval(SECOND(spec), Vlexical_environment));
new_lexical_variable(XCAR(spec), eval(SECOND(spec)));
if (!NILP(THIRD(spec))) {
new_lexical_variable(THIRD(spec), Qnil);
}
@@ -449,7 +449,7 @@ LispFunction *coerce_to_function(LispVal *orig_name, LispVal *func) {
if (SYMBOLP(func)) {
fobj = Fsymbol_function(func, Qt);
} else if (CONSP(func) && EQ(XCAR(func), Qlambda)) {
fobj = Feval(func, Vlexical_environment);
fobj = eval(func);
}
if (NILP(fobj)) {
lisp_signal(Qvoid_function_error, LIST(orig_name));
src/gc.c
+5
View File
@@ -308,6 +308,11 @@ static void mark_stack_frame(StackFrame *frame, size_t *restrict limit) {
mark_object(frame->dynamic_binding.old_value);
saturating_dec(limit, 2);
break;
case STACK_FRAME_BLOCK:
mark_object(frame->block.tag);
// leave protecting value up to internal-return-from
saturating_dec(limit, 1);
break;
}
}
src/gen-init-globals.awk
+6
View File
@@ -5,6 +5,7 @@ BEGIN {
special_syms["nil"] = 1
special_syms["unbound"] = 1
special_syms["lexical_environment"] = 1
special_syms["lexical_tags"] = 1
special_syms["hash_string"] = 1
special_syms["strings_equal"] = 1
special_syms["and_rest"] = 1
@@ -86,6 +87,11 @@ function maybe_emit_next_symbol(entity) {
maybe_emit_next_symbol("SPECIAL")
}
/DEFSPECIAL_NOINTERN\(/ {
maybe_print_file_header()
maybe_emit_next_symbol("SPECIAL_NOINTERN")
}
/DEFINE_SYMBOL\(/ {
maybe_print_file_header()
maybe_emit_next_symbol("SYMBOL")
src/lisp.c
+33 -20
View File
@@ -26,6 +26,8 @@ static void construct_manual_symbols(void) {
((LispSymbol *) Qlexical_environment)->value_type = SYMBOL_NATIVE;
((LispSymbol *) Qlexical_environment)->value.native = &Vlexical_environment;
lisp_gc_register_static_object(Qlexical_environment);
Qlexical_tags = Fmake_symbol(LISP_LITSTR("lexical-tags"));
lisp_gc_register_static_object(Qlexical_tags);
Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string"));
lisp_gc_register_static_object(Qhash_string);
@@ -38,7 +40,9 @@ static void register_manual_symbols(void) {
Fputhash(obarray, ((LispSymbol *) Q##cname)->name, Q##cname);
INTERN(nil);
INTERN(t);
INTERN(unbound);
// don't INTERN(unbound);
// don't INTERN(lexical_environment);
// don't INTERN(lexical_tags);
INTERN(hash_string);
INTERN(strings_equal);
#undef INTERN
@@ -73,8 +77,8 @@ void lisp_shutdown(void) {
lisp_gc_teardown();
}
static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) {
LispVal *lexval = Fplist_get(lexenv, name, Qunbound);
static inline LispVal *lookup_variable(LispSymbol *name) {
LispVal *lexval = Fplist_get(Vlexical_environment, name, Qunbound);
if (lexval != Qunbound) {
return lexval;
}
@@ -84,24 +88,22 @@ static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) {
return SYMBOL_VALUE(name);
}
static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args,
LispVal *lexenv) {
static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args) {
LispVal *start = Qnil;
LispVal *end = NULL;
DOLIST(arg, args) {
if (NILP(start)) {
start = CONS(Feval(arg, lexenv), Qnil);
start = CONS(eval(arg), Qnil);
end = start;
} else {
RPLACD(end, CONS(Feval(arg, lexenv), Qnil));
RPLACD(end, CONS(eval(arg), Qnil));
end = XCDR(end);
}
}
return start;
}
DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
"(form &optional lexenv)", "") {
LispVal *eval(LispVal *form) {
if (!OBJECTP(form)) {
// fixnum or float
return form;
@@ -119,25 +121,25 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
out_data[i] = Qnil;
}
for (size_t i = 0; i < vec->length; ++i) {
out_data[i] = Feval(vec->data[i], lexenv);
out_data[i] = eval(vec->data[i]);
}
return newvec;
}
case TYPE_SYMBOL:
return lookup_variable(form, lexenv);
return lookup_variable(form);
case TYPE_CONS: {
LispVal *res = XCAR(form);
if (SYMBOLP(res)) {
res = Fsymbol_function(res, Qt);
}
if (!NILP(Fmacrop(res))) {
return Feval(Fmacroexpand_all(form, Qnil), lexenv);
return eval(Fmacroexpand_all(form, Qnil));
}
LispVal *stack_ref = LISP_STACK_REF();
push_call_frame(XCAR(form), XCDR(form));
LispVal *evaled_args = XCDR(form);
if (NILP(Fspecial_form_p(res))) {
evaled_args = evaluate_function_arguments(XCDR(form), lexenv);
evaled_args = evaluate_function_arguments(XCDR(form));
}
LispVal *fobj = coerce_to_function(XCAR(form), res);
set_stack_evaluated_args(LISP_STACK_REF(), fobj, evaled_args);
@@ -150,10 +152,17 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
}
}
DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
"(form &optional lexenv)", "") {
StackFrame *stack_ref = LISP_STACK_REF();
push_dynamic_binding(Qlexical_environment, lexenv);
return UNWIND_AND_RETURN(stack_ref, eval(form));
}
DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") {
LispVal *rval = Qnil;
DOLIST(form, forms) {
rval = Feval(form, Vlexical_environment);
rval = eval(form);
}
return rval;
}
@@ -168,7 +177,7 @@ DEFSPECIAL(setq, "setq", (LispVal * bindings), "(&rest bindings)", "") {
for (LispVal *rest = bindings; !NILP(bindings);
bindings = XCDR(XCDR(bindings))) {
LispVal *name = FIRST(rest);
value = Feval(SECOND(rest), Vlexical_environment);
value = eval(SECOND(rest));
set_lexical_variable(name, value);
}
return value;
@@ -183,7 +192,7 @@ DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
if (!SYMBOLP(XCAR(binding))) {
signal_type_error(XCAR(binding), LIST(Qsymbol));
}
RPLACA(XCDR(binding), Feval(SECOND(binding), Vlexical_environment));
RPLACA(XCDR(binding), eval(SECOND(binding)));
} else if (!SYMBOLP(binding)) {
signal_type_error(binding, LIST(Qsymbol));
}
@@ -203,9 +212,9 @@ DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
DEFSPECIAL(if, "if", (LispVal * cond, LispVal *then, LispVal *otherwise),
"(cond then &rest else)", "") {
StackFrame *stack_ref = LISP_STACK_REF();
LispVal *res = Feval(cond, Vlexical_environment);
LispVal *res = eval(cond);
if (!NILP(res)) {
return UNWIND_AND_RETURN(stack_ref, Feval(then, Vlexical_environment));
return UNWIND_AND_RETURN(stack_ref, eval(then));
} else {
return UNWIND_AND_RETURN(stack_ref, Fprogn(otherwise));
}
@@ -214,7 +223,7 @@ DEFSPECIAL(if, "if", (LispVal * cond, LispVal *then, LispVal *otherwise),
DEFSPECIAL(and, "and", (LispVal * forms), "(&rest forms)", "") {
LispVal *res = Qt;
DOLIST(form, forms) {
res = Feval(form, Vlexical_environment);
res = eval(form);
if (NILP(res)) {
return Qnil;
}
@@ -224,7 +233,7 @@ DEFSPECIAL(and, "and", (LispVal * forms), "(&rest forms)", "") {
DEFSPECIAL(or, "or", (LispVal * forms), "(&rest forms)", "") {
DOLIST(form, forms) {
LispVal *res = Feval(form, Vlexical_environment);
LispVal *res = eval(form);
if (!NILP(res)) {
return res;
}
@@ -236,5 +245,9 @@ DEFUN(null, "null", (LispVal * datum), "(datum)", "") {
return NILP(datum) ? Qt : Qnil;
}
DEFUN(not, "not", (LispVal * datum), "(datum)", "") {
return NILP(datum) ? Qt : Qnil;
}
DEFINE_SYMBOL(unbound_variable_error, "unbound-variable-error");
DEFINE_CONDITION_CLASS(unbound_variable_error, error);
src/lisp.h
+2
View File
@@ -16,6 +16,7 @@ void lisp_init(void);
void lisp_shutdown(void);
LispVal *eval(LispVal *form);
DECLARE_FUNCTION(eval, (LispVal * form, LispVal *lexenv));
DECLARE_FUNCTION(progn, (LispVal * forms));
DECLARE_FUNCTION(setq, (LispVal * bindings));
@@ -24,6 +25,7 @@ DECLARE_FUNCTION(if, (LispVal * cond, LispVal *then, LispVal *otherwise));
DECLARE_FUNCTION(and, (LispVal * forms));
DECLARE_FUNCTION(or, (LispVal * forms));
DECLARE_FUNCTION(null, (LispVal * datum));
DECLARE_FUNCTION(not, (LispVal * datum));
DECLARE_SYMBOL(unbound_variable_error);
MAKE_CONDITION_CLASS(unbound_variable_error);
src/list.c
+1 -12
View File
@@ -141,24 +141,13 @@ DEFUN(nth, "nth", (LispVal * n, LispVal *list), "(n list)", "") {
return nth(XFIXNUM(n), list);
}
DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred),
"(elt list &optional pred)", "") {
if (NILP(pred) || pred == Qeq) {
// fast case
DEFUN(memq, "memq", (LispVal * elt, LispVal *list), "(elt list)", "") {
DOTAILS(rest, list) {
CHECK_LISTP(rest);
if (elt == XCAR(rest)) {
return rest;
}
}
} else {
DOTAILS(rest, list) {
CHECK_LISTP(rest);
if (!NILP(CALL(pred, elt, XCAR(rest)))) {
return rest;
}
}
}
return Qnil;
}
src/list.h
+1 -1
View File
@@ -142,7 +142,7 @@ static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) {
}
// List utility functions
DECLARE_FUNCTION(member, (LispVal * elt, LispVal *list, LispVal *pred));
DECLARE_FUNCTION(memq, (LispVal * elt, LispVal *list));
DECLARE_FUNCTION(member_if, (LispVal * pred, LispVal *list));
DECLARE_FUNCTION(plist_put, (LispVal * plist, LispVal *prop, LispVal *value));
src/macro.c
+2 -1
View File
@@ -102,7 +102,8 @@ static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form,
return macroexpand_lambda_form(form, lexical_macros);
} else if (IS(quote)) {
return form;
} else if (IS(progn) || IS(if) || IS(and) || IS(or)) {
} else if (IS(progn) || IS(if) || IS(and) || IS(or) || IS(block)
|| IS(return_from)) {
if (LISTP(XCDR(form))) {
return CONS(XCAR(form),
macroexpand_list(XCDR(form), lexical_macros));
src/stack.c
+69 -5
View File
@@ -2,6 +2,7 @@
#include "function.h"
#include "hashtable.h"
#include "lisp.h"
#include "list.h"
#include "memory.h"
#include "print.h"
@@ -80,6 +81,7 @@ void set_stack_evaluated_args(StackFrame *restrict frame, LispVal *fobj,
LispVal *args) {
gc_mark_stack_for_rescan();
assert(frame->kind == STACK_FRAME_CALL);
frame->call.fobj = fobj;
frame->call.args = args;
frame->call.evaled_args = true;
}
@@ -299,6 +301,7 @@ void unwind_to(StackFrame *frame) {
break;
case STACK_FRAME_HANDLER_BIND:
case STACK_FRAME_CALL:
case STACK_FRAME_BLOCK:
// nothing to do
break;
}
@@ -362,21 +365,82 @@ noreturn void lisp_signal(LispVal *name, LispVal *data) {
top_of_stack_exception_handler(name, data);
}
static void check_block_name(LispVal *name) {
if (!SYMBOLP(name) || NILP(name)) {
signal_type_error(name, LIST(Qsymbol, LIST(Qnot, Qnull)));
}
}
DEFSPECIAL(block, "block", (LispVal * name, LispVal *body), "(name &rest body)",
"") {
name = eval(name);
check_block_name(name);
if (!SYMBOLP(name))
CHECK_TYPE(name, TYPE_SYMBOL);
LispVal *volatile return_value = Qnil;
jmp_buf target;
StackFrame *stack_ref = LISP_STACK_REF();
LispVal *tag = Fmake_symbol(((LispSymbol *) name)->name);
LispVal *cur_tags = Fplist_get(Vlexical_environment, name, Qnil);
push_copy_lexenv();
new_lexical_variable(Qlexical_tags, CONS(CONS(name, tag), cur_tags));
StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_BLOCK);
frame->block.tag = tag;
frame->block.target = &target;
frame->block.value_ptr = &return_value;
frame->block.unwind_to = stack_ref;
if (setjmp(target) == 0) {
return UNWIND_AND_RETURN(stack_ref, Fprogn(body));
} else {
// return-from handles unwinding and putting the return value in a local
// references frame
return return_value;
}
}
static LispVal *lookup_block_tag(LispVal *name) {
LispVal *tags = Fplist_get(Vlexical_environment, Qlexical_tags, Qnil);
LispVal *ent = Fassoc(name, tags, Qnil);
return CONSP(ent) ? XCDR(ent) : Qunbound;
}
DEFSPECIAL(return_from, "return-from", (LispVal * name, LispVal *value),
"(name &optional value)", "") {
name = eval(name);
check_block_name(name);
LispVal *tag = lookup_block_tag(name);
if (tag != Qunbound) {
for (ptrdiff_t i = the_stack.depth; i >= 0; --i) {
StackFrame *restrict frame = &the_stack.frames[i];
if (frame->kind == STACK_FRAME_BLOCK && EQ(frame->block.tag, tag)) {
add_local_reference(frame->block.unwind_to, value);
*frame->block.value_ptr = value;
unwind_to(frame->block.unwind_to);
longjmp(*frame->block.target, 1);
}
}
}
// block went out of scope
lisp_signal(Qno_such_block_error, LIST(name));
}
DEFUN(backtrace, "backtrace", (void), "()", "") {
LispVal *out = Qnil;
for (size_t i = 0; i < the_stack.depth; ++i) {
StackFrame *restrict frame = &the_stack.frames[i];
if (frame->kind == STACK_FRAME_CALL) {
LispVal *name = frame->call.name;
// fobj is NULL (not Qnil) if the arguments haven't been evaluated
out = CONS(LIST(frame->call.name,
frame->call.fobj ? frame->call.fobj : Qnil,
frame->call.evaled_args ? Qt : Qnil,
frame->call.args),
out);
LispVal *fobj = frame->call.fobj ? frame->call.fobj : Qnil;
LispVal *did_eval_args = frame->call.evaled_args ? Qt : Qnil;
LispVal *args = frame->call.args;
out = CONS(LIST(name, fobj, did_eval_args, args), out);
}
}
return out;
}
DEFINE_SYMBOL(no_such_block_error, "no-such-block-error");
DEFINE_CONDITION_CLASS(no_such_block_error, error);
DEFINE_SYMBOL(excessive_lisp_nesting_error, "excessive-lisp-nesting-error");
DEFINE_CONDITION_CLASS(excessive_lisp_nesting_error, error);
src/stack.h
+13
View File
@@ -3,6 +3,7 @@
#include "base.h"
#include <setjmp.h>
#include <stdnoreturn.h>
enum StackFrameKind {
@@ -11,6 +12,7 @@ enum StackFrameKind {
STACK_FRAME_UNWIND_PROTECT,
STACK_FRAME_HANDLER_BIND,
STACK_FRAME_DYNAMIC_BINDING,
STACK_FRAME_BLOCK,
};
#define LISP_STACK_MAX_DEPTH 4096
@@ -58,6 +60,12 @@ struct _StackFrame {
LispVal *symbol;
LispVal *old_value;
} dynamic_binding;
struct {
LispVal *tag;
jmp_buf *target;
LispVal *volatile *value_ptr;
StackFrame *unwind_to;
} block;
};
};
@@ -139,11 +147,16 @@ static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame,
noreturn void lisp_signal(LispVal *name, LispVal *data);
DECLARE_FUNCTION(block, (LispVal * name, LispVal *body));
DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value));
/**
* Backtraces have the form (name fobj evaled? args)
*/
DECLARE_FUNCTION(backtrace, (void) );
DECLARE_SYMBOL(no_such_block_error);
MAKE_CONDITION_CLASS(no_such_block_error);
DECLARE_SYMBOL(excessive_lisp_nesting_error);
MAKE_CONDITION_CLASS(excessive_lisp_nesting_error);