Compare commits

..

89 commits

Author SHA1 Message Date
Daniel Kochmański
671e578c7e [nucl] smaller stacks 2025-11-30 21:24:51 +01:00
Daniel Kochmański
3b25b8c8b4 [nucl] fix the compiled code size and cleanup the dictionary
Previously we've wrongly estimated that the vector with opcodes has the same
length as the number of words, but:

CALLW takes an argument denoting the index of the function on data stack
PUSHQ takes an argument denoting the index of the literal on data stack

Moreover rename some dictionary entries for more descriptive names and add a new
word .V that prints values stored in the environment.
2025-11-30 21:24:51 +01:00
Daniel Kochmański
d7d446bfff [nucl] _nucl_word_dispatch use a stack-allocated frame
nucl_stack_frame is not always defined when we call to this function.
2025-11-30 21:24:51 +01:00
Daniel Kochmański
4880d93a6d [nucl] add all opcodes to the dictionary 2025-11-30 21:24:51 +01:00
Daniel Kochmański
ae20397968 [nucl] words operate directly on the stack
In the first sketch they operated on stack frames, but this approach was flawed
because a) leaving things on the stack above frame prevented it from growing
leading to an internal error, b) closing the frame wiped all values deposited on
the stack that were above the frame base.
2025-11-30 21:24:51 +01:00
Daniel Kochmański
cd89c1f432 [nucl] write a forth compiler 2025-11-30 21:24:51 +01:00
Daniel Kochmański
ebab441f31 [nucl] add a (mock for now) function nucl_compile_definition 2025-11-30 21:24:51 +01:00
Daniel Kochmański
0fcb28f3cb [nucl] don't modify VALUES vector and use dynamic STDIN/STDOUT vals 2025-11-30 21:24:51 +01:00
Daniel Kochmański
fcd91a20c2 [nucl] liberate stack frames from stack allocation terror 2025-11-30 21:24:51 +01:00
Daniel Kochmański
8eb45e7041 [nucl] don't pop if the item was not added 2025-11-30 21:24:51 +01:00
Daniel Kochmański
113f22b6a8 [nucl] clean up the file (move things around) 2025-11-30 21:24:51 +01:00
Daniel Kochmański
01e6c4ef27 [nucl] implement word definition 2025-11-30 21:24:51 +01:00
Daniel Kochmański
9a57760a54 [nucl] add a compilation mode (doesn't actually compile yet) 2025-11-30 21:24:51 +01:00
Daniel Kochmański
5f61baef64 [nucl] resolve words only when called, otherwise return symbols
This is necessary for defining new words and allows us to move the dictionary
implementation after the reader.
2025-11-30 21:24:51 +01:00
Daniel Kochmański
f23b46bbbd [nucl] add to the dictionary word pop 2025-11-30 21:24:51 +01:00
Daniel Kochmański
013075a8d7 [nucl] reorganize file and add "print stack" word 2025-11-30 21:24:51 +01:00
Daniel Kochmański
7bf3a380f3 [nucl] allow calling into words and properly maintain the stack
This commit takes a correction over things corrected (and rebased) in
refactor-stacks branch.

consturctors nucl_stack_to_foo remove elements from the stack and leave the
parsed element on the stack.

Move specials at the beginning.
2025-11-30 21:24:51 +01:00
Daniel Kochmański
903c4c44e8 [nucl] fix eof issues and add reading the line of objects 2025-11-30 21:24:51 +01:00
Daniel Kochmański
43e4187034 [nucl] allow extending the dictionary and make it a special variable 2025-11-30 21:24:51 +01:00
Daniel Kochmański
7ca2fc29ab [nucl] add a provisionary symbol dictionary 2025-11-30 21:24:51 +01:00
Daniel Kochmański
fd2af0ad73 [nucl] add a proto-repl without eval step 2025-11-30 21:24:51 +01:00
Daniel Kochmański
df436f5139 [nucl] use the data stack 2025-11-30 21:24:51 +01:00
Daniel Kochmański
a44cb96fa5 [nucl] skip whitespace in the reader 2025-11-30 21:24:51 +01:00
Daniel Kochmański
e47f37a104 [nucl] parse fixnums and hexnums 2025-11-30 21:24:51 +01:00
Daniel Kochmański
0bd275dd30 [nucl] implement basic reader and writer 2025-11-30 21:24:51 +01:00
Daniel Kochmański
82b0b415f6 [nucl] stacks: add a few unsafe operations 2025-11-30 21:24:51 +01:00
Daniel Kochmański
361a65e0b5 [nucl] add barebones reader 2025-11-30 21:24:51 +01:00
Daniel Kochmański
da85aeb104 [nucl] strm_nucl implement unread char 2025-11-30 21:24:51 +01:00
Daniel Kochmański
b07dc53b34 [nucl] add Lali-ho I/O 2025-11-30 21:24:51 +01:00
Daniel Kochmański
bd65f0c4cc [nucl] implement a barebones stream 2025-11-30 21:24:51 +01:00
Daniel Kochmański
da7ff0e8bf [nucl] add a mock stream 2025-11-30 21:24:51 +01:00
Daniel Kochmański
0058af914f [bytevm] [wip] new opcode CALLW, don't use lcl frame when no locals
CALLW calls a word from the data stack. The word differs from normal functions
in that it takes no arguments (so the call does not modify the data stack).

To allow words using the stack across calls (like in "real" forth) don't unwind
the stack on exit if there are no locals.
2025-11-30 21:24:39 +01:00
Daniel Kochmański
69b8ef4842 stream: port stream.d so it can be used with early env
This is a step towards introducing the I/O system.
2025-11-30 21:22:56 +01:00
Daniel Kochmański
98b887a7ea [nucl] showcase calling into ecl_interpret 2025-11-30 21:22:56 +01:00
Daniel Kochmański
d706faa600 nucleus: build nucleus directly from .c files (not .o) 2025-11-30 21:22:56 +01:00
Daniel Kochmański
d1241fbe02 [bytevm][wip] bytevm: allocate stack manually
wip tag because:

- we don't free tha stack (we use alloc_memory)
2025-11-30 21:22:56 +01:00
Daniel Kochmański
08f809d2f8 [wip] memory: ensure disabled interrupts in top-level operators
ecl_alloc_object, ecl_free_object
ecl_alloc, ecl_alloc_manual, ecl_alloc_atomic, ecl_dealloc

Moreover move all top-level ops to memory.d so they are not reliant on mem_gc.
The stubbed allocator uses manual memory managament for all ops.

[wip] because we should adjust ecl_make_stack too
2025-11-30 21:22:56 +01:00
Daniel Kochmański
6232de673d type_info: reify the type_info database
We store information about the object size, its pointers and name. This
information is later reused by the garbage collector.
2025-11-30 21:22:56 +01:00
Daniel Kochmański
71d8535442 nucleus: move ecl_cons to memory.d
ecl_cons requires a separate allocator because it may be a small cons.
2025-11-30 21:22:56 +01:00
Daniel Kochmański
d58bab2a26 memory: make it possible to configure the allocator 2025-11-30 21:22:56 +01:00
Daniel Kochmański
24edc0a250 [wip] nucl: binary and preliminary notes 2025-11-30 21:22:56 +01:00
Daniel Kochmański
562df3f4b3 msvc: update the makefile and specify /std:c11 minimal standard
MSVC does not allow for specifying /std:c99 so we need c11. We don't rely on the
default standard because it does not allow for static struct initializers.
2025-11-30 21:22:56 +01:00
Daniel Kochmański
c772ea3073 nucleus: move ecl_eql to a separate file
This is a low-level comparison operator. We opencode EQL comparison for bignums
to avoid a dependency on GMP (in this file).
2025-11-30 21:22:56 +01:00
Daniel Kochmański
f41fb2ae38 nucleus: introduce a table with early symbols ecl_symbols
This table contains symbols that are essential to the core runtime: ECL_T,
ECL_UNBOUND, ECL_SIGNAL_HANDLERS, ECL_RESTART_CLUSTERs, ECL_INTERRUPTS_ENABLED,
ECL_ALLOW_OTHER_KEYS and ECL_UNBOUND.

The table is initialized with constexpr, so it is possible to use its elements
in static elements. We also add ecl_def_function to ecl-inl to allow
appropriating C functions into Lisp world at top level.
2025-11-30 21:22:56 +01:00
Daniel Kochmański
0fa2095bd8 nucleus: move early stacks to a separate file
This is necessary if we want to link them into nucleus without CL env baggage.
2025-11-30 21:22:53 +01:00
Daniel Kochmański
9c6f31f408 nucleus: move aux throw/go/tagbody implementations to jump.d 2025-11-30 21:20:40 +01:00
Daniel Kochmański
e10bb675b0 modules: uninstall signal handlers when unixint is destroyed 2025-11-30 21:20:40 +01:00
Daniel Kochmański
0ce6adb1c2 modules: deallocate stacks when modules are destroyed 2025-11-30 21:20:40 +01:00
Daniel Kochmański
156704b5dd modules: release all resources on ecl_halt
Previously we were lazy and simply marked the runtime as "not booted", but now
we do perform a proper shutdown.
2025-11-30 21:20:40 +01:00
Daniel Kochmański
8432685284 process: move process initialization to the process module hooks 2025-11-30 21:20:40 +01:00
Daniel Kochmański
8573c58768 garbage: register and unregister GC threads manually from a module
This decouples thread primitives from the garbage collector and allows us to
build nucl once more.
2025-11-30 21:20:40 +01:00
Daniel Kochmański
511389c126 process: abstract away create thread, exit thread and sigmask
Previously we've opencoded calls to these functions, although they may be nicely
abstracted with static inline functions. This change improves code readibility
and portability.
2025-11-30 21:20:40 +01:00
Daniel Kochmański
f567c1829e modules: [A/n] move the environment allocators to nucleus
Also clean up initialization code across different paths to have the same order.
2025-11-30 21:20:40 +01:00
Daniel Kochmański
5e20d8bd9a modules: [9/n] introduce ecl_module_thread 2025-11-30 21:20:39 +01:00
Daniel Kochmański
c488a5ffd3 modules: [7/n] introduce ecl_module_stacks 2025-11-30 21:20:39 +01:00
Daniel Kochmański
e550aad6ef modules: [6/n] introduce ecl_module_aux 2025-11-30 21:20:39 +01:00
Daniel Kochmański
13e14742a6 modules: [5/n] introduce ecl_module_ffi 2025-11-30 21:20:39 +01:00
Daniel Kochmański
9c1ae979f4 modules: [4/n] introduce ecl_module_bignum 2025-11-30 21:20:39 +01:00
Daniel Kochmański
46b0aa512d modules: [3/n] introduce ecl_module_process 2025-11-30 21:20:39 +01:00
Daniel Kochmański
10c03bedfc modules: [2/n] introduce ecl_module_unixint 2025-11-30 21:20:39 +01:00
Daniel Kochmański
05255a56e9 modules: [1/n] introduce ecl_module_gc
We also remove conditionalization for garbage collector inclusion in autotools.
When we propose an alternative gc, then we may decide to put them back, or to
add necessary ifdef statements directly in files.

Moreover untangle c-stack from the gc code and assign the stack base with a
rough guess only when it is not initialized yet (GC will always fill it).

Finally remove a kludge from ecl_adopt_cpu and disable colleciton until the cpu
is fully initialized.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
dabaf19c2d modules: [0/n] introduce a new structure ecl_module in the system
This will allow us to decouple forward system initialization from the early
process code.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
9cf792a9ee process: move ecl_clear_bignum_registers to _dealloc_env
This resolves a fixme.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
9ff07f7667 process: use GC_thread_is_registered() instead of the_env->cleanup
This allows us to remove unnecessary bookkeeping.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
d990d2afd5 nucleus: [2/n] move processing unit managament to nucleus 2025-11-30 21:20:39 +01:00
Daniel Kochmański
71d5f8dd78 nucleus: [1/n] move processing unit managament to nucleus 2025-11-30 21:20:39 +01:00
Daniel Kochmański
6fb1b5e9e1 exceptions: define *SIGNAL-HANDLERS* in cold_boot
I've also renamed *HANDLER-CLUSTERS* to a more appropriate *SIGNAL-HANDLERS*.
Currently this symbol is imported to the SYSTEM package, although this may be
revised in the future to cater to multiple global environments. Alternatively
the SYSTEM package may be common to all runtimes.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
5ce3a2be4d exceptions: dispatch signals exceptions (not conditions) 2025-11-30 21:20:39 +01:00
Daniel Kochmański
15013d2352 exceptions: runtime stack error signals exceptions (not conditions)
Replace calls to CEstack_overflow with exceptions - this is a necessary step
before moving stacks into nucleus.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
4320237c6a exceptions: interpreter signals exceptions (not conditions) 2025-11-30 21:20:39 +01:00
Daniel Kochmański
7bc1bade1b exceptions: introduce the concept of an exception
The exception in CL is resignaled as a condition.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
a64870cb72 exceptions: introduce signals to the early environment 2025-11-30 21:20:39 +01:00
Daniel Kochmański
90d6e21697 exceptions: rewrite signal handling to use functions and not lists
Instead of storing lists in *HANDLER-CLUSTERS*, we define functions that are
called unconditionally on the handler. HANDLER-BIND defines that function to be
a typecase that is dispatched based on the conditiont type, as specified by CL.

This change will aid further refactor.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
a2021f1afd nucleus: move ecl_core_struct to nucleus 2025-11-30 21:20:39 +01:00
Daniel Kochmański
6f07bed6c7 nucleus: move protect and dummy tags to boot.d 2025-11-30 21:20:39 +01:00
Daniel Kochmański
0d986c58d6 nucleus: move early constants from main.d to boot.d 2025-11-30 21:20:39 +01:00
Daniel Kochmański
617680e4d5 nucleus: add a module boot for booting the core
Currently it contains only option setters.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
fc68057fc0 core: add a module for program control transfer
Currently it contains early errors and backtrace.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
be5aa38bd1 apply: move funcall and apply-from-stack eval.d -> apply.d 2025-11-30 21:20:39 +01:00
Daniel Kochmański
e40849cfd3 core: split cl_core_struct in two structure cl_core and ecl_core
ecl_core contains early global environment that is meant to be shared by all
runtimes, while cl_core contains an environment relevant to common lisp.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
a7f71259ed core: define protect and dummy tags as constants
Both tags have a special meaning to the low-level runtime (most notably the
frame stack). Extracting them from "all symbols" is a step towards multiple
runtimes.
2025-11-30 21:20:39 +01:00
Daniel Kochmański
9314e8b192 core: move defacto constants from cl_core structure to global space 2025-11-30 21:20:39 +01:00
Marius Gerbershagen
855f93431b Merge branch 'fix-799' into 'develop'
Fix :variables command in top-level env

Closes #799

See merge request embeddable-common-lisp/ecl!359
2025-11-30 14:52:28 +00:00
Daniel Kochmański
9f9c9a8037 cmp: assign _ecl_debug_env to lcl_env (not lex_env) 2025-11-29 22:22:41 +01:00
Daniel Kochmański
dfb691ede8 top: add captured records to the local environment
We include captured functions, blocks and variables along with local
variables. This fixes #799.

Moreover DECODE-IHS-ENV is deperacated and more DWIM:
- calls DECODE-IHS-LOCALS for old arguments
- appends DECODE-IHS-LOCALS and DECODE-IHS-LEXENV for ihs index

DECODE-IHS-LOCALS and DECODE-IHS-LEXENV are responsible for decoding appropriate
environments.
2025-11-28 13:13:04 +01:00
Daniel Kochmański
e6ae6146a4 ihs/swank: make si_ihs_env return the local environment (not lexical)
We deprecate the function si_ihs_env in favor of more explicit si_ihs_lex and
si_ihs_lcl, but the former is left for backward compatibility with SLIME/SLYNK
because they call it to query the environment to add locals to the backtrace.
2025-11-28 11:57:09 +01:00
Daniel Kochmański
8a5007fd4a top: separate correctly lexenv from lclenv in break environment
Fixes #799.
2025-11-28 11:57:09 +01:00
Daniel Kochmański
ed5471169e ihs: store locals and lexical environment in separate slots
Since ~recently we store local variables in the bytevm on the stack.  Also, the
native comipler under specified debug options, stores locals in ihs, but it has
nothing to do with the lexical environment. So it feels justified to push both
to a separate field.
2025-11-28 11:57:09 +01:00
Daniel Kochmański
3c4c1639c5 proclamations: fix an invalid proclamation for SI:IHS-ENV
It may seem like this proclamation is invalid sincd !346, but the divergence
happens much earlier. 8c0314022c introduces a
feature where c-compiled code can also add debug information, and in that case
the environment is a vector, so the proclamation back then should be:

  (proclamation si:ihs-env (si::index) (or list vector))

Later when we've changed the representation, it should be changed to

  (proclamation si:ihs-env (si::index) (or null vector))

Where NULL denotes "no lexical environment".
2025-11-28 11:57:09 +01:00
12 changed files with 145 additions and 88 deletions

View file

@ -551,7 +551,7 @@ c_macro_expand1(cl_env_ptr env, cl_object stmt)
static void
import_lexenv(cl_env_ptr env, cl_object lexenv)
{
if (!ECL_VECTORP(lexenv))
if (Null(lexenv))
return;
/*
* Given the environment of an interpreted function, we guess a

View file

@ -396,7 +396,7 @@ FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type)
function = cl_symbol_or_object(function);
type = cl_symbol_or_object(type);
if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
}
si_signal_simple_error(8,
@'type-error', /* condition name */
@ -420,7 +420,7 @@ FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_objec
function = cl_symbol_or_object(function);
type = cl_symbol_or_object(type);
if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
}
si_signal_simple_error(8,
@'type-error', /* condition name */
@ -446,7 +446,7 @@ FEwrong_type_key_arg(cl_object function, cl_object key, cl_object value, cl_obje
type = cl_symbol_or_object(type);
key = cl_symbol_or_object(key);
if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
}
si_signal_simple_error(8,
@'type-error', /* condition name */
@ -477,7 +477,7 @@ FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx,
struct ecl_ihs_frame tmp_ihs;
function = cl_symbol_or_object(function);
if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
}
cl_error(9,
@'simple-type-error', /* condition name */

View file

@ -409,7 +409,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
/* INV: bytecodes is of type t_bytecodes */
lcl_env = ecl_cast_ptr(cl_object, &frame_lcl);
ecl_cs_check(the_env, ihs);
ecl_ihs_push(the_env, &ihs, bytecodes, closure);
ecl_ihs_push(the_env, &ihs, bytecodes, closure, lcl_env);
if(nlcl) ecl_stack_frame_open(the_env, lcl_env, nlcl);
frame_aux.t = t_frame;
frame_aux.opened = 0;

View file

@ -167,12 +167,27 @@ si_ihs_fun(cl_object arg)
}
cl_object
si_ihs_env(cl_object arg)
si_ihs_lex(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env);
}
cl_object
si_ihs_lcl(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lcl_env);
}
/* DEPRECATED backward compatibility with SWANK/SLYNK. --jd 2025-11-17 */
cl_object
si_ihs_env(cl_object arg)
{
cl_env_ptr env = ecl_process_env();
ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lcl_env);
}
/* -- Lisp ops on stacks ---------------------------------------------------- */
cl_object

View file

@ -1215,6 +1215,8 @@ cl_symbols[] = {
{SYS_ "HASH-TABLE-ITERATOR" ECL_FUN("si_hash_table_iterator", si_hash_table_iterator, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "IHS-BDS" ECL_FUN("si_ihs_bds", si_ihs_bds, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "IHS-ENV" ECL_FUN("si_ihs_env", si_ihs_env, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "IHS-LEX" ECL_FUN("si_ihs_lex", si_ihs_lex, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "IHS-LCL" ECL_FUN("si_ihs_lcl", si_ihs_lcl, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "IHS-FUN" ECL_FUN("si_ihs_fun", si_ihs_fun, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "IHS-NEXT" ECL_FUN("si_ihs_next", si_ihs_next, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "IHS-PREV" ECL_FUN("si_ihs_prev", si_ihs_prev, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},

View file

@ -199,7 +199,7 @@
(wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");"))
(case ihs-p
(IHS (wt-nl "ecl_ihs_pop(cl_env_copy);"))
(IHS-ENV (wt-nl "ihs.lex_env = _ecl_debug_env;"))))
(IHS-ENV (wt-nl "ihs.lcl_env = _ecl_debug_env;"))))
(defun %unwind (into from)
(declare (si::c-local))

View file

@ -207,7 +207,7 @@
(push 'IHS *unwind-exit*)
(when (policy-debug-variable-bindings)
(build-debug-lexical-env (reverse requireds) t))
(wt-nl "ecl_ihs_push(cl_env_copy,&ihs," fname ",_ecl_debug_env);")))
(wt-nl "ecl_ihs_push(cl_env_copy,&ihs," fname ",ECL_NIL,_ecl_debug_env);")))
;; Bind optional parameters as long as there remain arguments.
(when optionals

View file

@ -75,11 +75,11 @@
(+ 2 (length filtered-locations))
",,);")
(unless first
(wt-nl "ihs.lex_env = _ecl_debug_env;")))
(wt-nl "ihs.lcl_env = _ecl_debug_env;")))
filtered-codes))
(defun pop-debug-lexical-env ()
(wt-nl "ihs.lex_env = _ecl_debug_env;"))
(wt-nl "ihs.lcl_env = _ecl_debug_env;"))
(defun c2let* (c1form vars forms body
&aux

View file

@ -298,7 +298,9 @@
(proclamation si:ihs-top () si::index)
(proclamation si:ihs-fun (si::index) (or null function-designator))
(proclamation si:ihs-env (si::index) environment)
(proclamation si:ihs-env (si::index) (or null vector))
(proclamation si:ihs-lex (si::index) (or null vector))
(proclamation si:ihs-lcl (si::index) (or null vector si::frame))
(proclamation si:frs-top () si::index)
(proclamation si:frs-bds (si::index) si::index)
(proclamation si:frs-tag (si::index) t)

View file

@ -1649,6 +1649,8 @@ extern ECL_API __m128d ecl_unbox_double_sse_pack(cl_object value);
extern ECL_API cl_object si_ihs_top(void);
extern ECL_API cl_object si_ihs_fun(cl_object arg);
extern ECL_API cl_object si_ihs_env(cl_object arg);
extern ECL_API cl_object si_ihs_lex(cl_object arg);
extern ECL_API cl_object si_ihs_lcl(cl_object arg);
extern ECL_API cl_object si_ihs_bds(cl_object arg);
extern ECL_API cl_object si_ihs_next(cl_object arg);
extern ECL_API cl_object si_ihs_prev(cl_object arg);

View file

@ -233,16 +233,18 @@ typedef struct ecl_ihs_frame {
struct ecl_ihs_frame *next;
cl_object function;
cl_object lex_env;
cl_object lcl_env;
cl_index index;
cl_index bds;
} *ecl_ihs_ptr;
#define ecl_ihs_push(env,rec,fun,lisp_env) do { \
#define ecl_ihs_push(env,rec,fun,lex,lcl) do { \
const cl_env_ptr __the_env = (env); \
ecl_ihs_ptr const r = (ecl_ihs_ptr const)(rec); \
r->next=__the_env->ihs_stack.top; \
r->function=(fun); \
r->lex_env=(lisp_env); \
r->lex_env=(lex); \
r->lcl_env=(lcl); \
r->index=__the_env->ihs_stack.top->index+1; \
r->bds=__the_env->bds_stack.top - __the_env->bds_stack.org; \
__the_env->ihs_stack.top = r; \

View file

@ -26,7 +26,8 @@
(defparameter *quit-tag* (cons nil nil))
(defparameter *quit-tags* nil)
(defparameter *break-level* 0) ; nesting level of error loops
(defparameter *break-env* nil)
(defparameter *break-lexenv* nil)
(defparameter *break-locals* nil)
(defparameter *ihs-base* 0)
(defparameter *ihs-top* (ihs-top))
(defparameter *ihs-current* 0)
@ -601,7 +602,7 @@ Use special code 0 to cancel this operation.")
(tpl-prompt)
(tpl-read))
values (multiple-value-list
(eval-with-env - *break-env*))
(eval-with-env - *break-lexenv*))
/// // // / / values *** ** ** * * (car /))
(tpl-format "~&~{~s~^~%~}~%" values)))))
(loop
@ -904,76 +905,106 @@ Use special code 0 to cancel this operation.")
@(return) = CONS(name,output);
" :one-liner nil))
(defun decode-ihs-env (*break-env*)
(let ((env *break-env*))
(if (vectorp env)
#+ecl-min
nil
#-ecl-min
(let* ((next (decode-ihs-env
(ffi:c-inline (env) (:object) :object
"(#0)->vector.self.t[0]" :one-liner t))))
(nreconc (loop with l = (- (length env) 2)
for i from 0 below l
do (push (decode-env-elt env i) next))
next))
env)))
;;; This function is here for backward compatibility. We also extend it to
;;; "simply work" with ihs indexes - then it decodes both locals and lexenv.
(defun decode-ihs-env (env)
(etypecase env
((or vector si:frame)
(decode-ihs-locals env))
(integer
(append (decode-ihs-locals (ihs-lcl env))
(decode-ihs-lexenv (ihs-lex env))))
(null
nil)))
(defun decode-ihs-locals (env)
#+ecl-min nil
#-ecl-min
(etypecase env
(vector
(let ((next (decode-ihs-locals
(ffi:c-inline (env) (:object) :object
"(#0)->vector.self.t[0]" :one-liner t))))
(nreconc (loop with l = (- (length env) 2)
for i from 0 below l
do (push (decode-env-elt env i) next))
next)))
(si:frame
(let* ((lcls '()))
(ffi:c-inline (env lcls) (:object :object) :void
"loop_across_frame_fifo(elt, (#0)) {
(#1)=ecl_cons(elt, (#1));
} end_loop_across_frame();")
lcls))
(null
nil)))
(defun decode-ihs-lexenv (env)
#+ecl-min nil
#-ecl-min
(etypecase env
(vector
(loop for elt across env collect elt))
(null
nil)))
(defun ihs-environment (ihs-index)
(labels ((newly-bound-special-variables (bds-min bds-max)
(loop for i from bds-min to bds-max
for variable = (bds-var i)
unless (member variable output :test #'eq)
collect variable into output
finally (return output)))
(special-variables-alist (ihs-index)
(let ((top (ihs-top)))
(unless (> ihs-index top)
(let* ((bds-min (1+ (ihs-bds ihs-index)))
(bds-top (bds-top))
(bds-max (if (= ihs-index top)
bds-top
(ihs-bds (1+ ihs-index))))
(variables (newly-bound-special-variables bds-min bds-max)))
(loop with output = '()
for i from (1+ bds-max) to bds-top
for var = (bds-var i)
when (member var variables :test #'eq)
do (setf variables (delete var variables)
output (acons var (bds-val i) output))
finally (return
(append (loop for v in variables
collect (cons v (symbol-value v)))
output)))))))
(extract-restarts (variables-alist)
(let ((record (assoc '*restart-clusters* variables-alist)))
(if record
(let* ((bindings (cdr record))
(new-bindings (first bindings)))
(values (delete record variables-alist) new-bindings))
(values variables-alist nil)))))
(let* ((functions '())
(blocks '())
(local-variables '())
(special-variables '())
(restarts '())
record0 record1)
(dolist (record (decode-ihs-env (ihs-env ihs-index)))
(cond ((atom record)
(push (compiled-function-name record) functions))
((progn
(setf record0 (car record) record1 (cdr record))
(when (stringp record0)
(setf record0
(let ((*package* (find-package "KEYWORD")))
(with-standard-io-syntax
(read-from-string record0)))))
(or (symbolp record0) (stringp record0)))
(setq local-variables (acons record0 record1 local-variables)))
((symbolp record1)
(push record1 blocks))
(t
)))
(let ((functions '())
(blocks '())
(local-variables '())
(special-variables '())
(restarts '())
record0 record1)
(labels ((newly-bound-special-variables (bds-min bds-max)
(loop for i from bds-min to bds-max
for variable = (bds-var i)
unless (member variable output :test #'eq)
collect variable into output
finally (return output)))
(special-variables-alist (ihs-index)
(let ((top (ihs-top)))
(unless (> ihs-index top)
(let* ((bds-min (1+ (ihs-bds ihs-index)))
(bds-top (bds-top))
(bds-max (if (= ihs-index top)
bds-top
(ihs-bds (1+ ihs-index))))
(variables (newly-bound-special-variables bds-min bds-max)))
(loop with output = '()
for i from (1+ bds-max) to bds-top
for var = (bds-var i)
when (member var variables :test #'eq)
do (setf variables (delete var variables)
output (acons var (bds-val i) output))
finally (return
(append (loop for v in variables
collect (cons v (symbol-value v)))
output)))))))
(extract-restarts (variables-alist)
(let ((record (assoc '*restart-clusters* variables-alist)))
(if record
(let* ((bindings (cdr record))
(new-bindings (first bindings)))
(values (delete record variables-alist) new-bindings))
(values variables-alist nil))))
(process-env-record (record)
(cond ((atom record)
(push (compiled-function-name record) functions))
((progn
(setf record0 (car record) record1 (cdr record))
(when (stringp record0)
(setf record0
(let ((*package* (find-package "KEYWORD")))
(with-standard-io-syntax
(read-from-string record0)))))
(or (symbolp record0) (stringp record0)))
(setq local-variables (acons record0 record1 local-variables)))
((symbolp record1)
(push record1 blocks))
(t
))))
(map nil #'process-env-record (decode-ihs-locals (ihs-lcl ihs-index)))
(map nil #'process-env-record (decode-ihs-lexenv (ihs-lex ihs-index)))
(multiple-value-bind (special-variables restarts)
(extract-restarts (special-variables-alist ihs-index))
(values (nreverse local-variables)
@ -1017,7 +1048,7 @@ Use special code 0 to cancel this operation.")
(defun tpl-inspect-command (var-name)
(when (symbolp var-name)
(setq var-name (symbol-name var-name)))
(let ((val-pair (assoc var-name (decode-ihs-env *break-env*)
(let ((val-pair (assoc var-name (decode-ihs-locals *break-locals*)
:test #'(lambda (s1 s2)
(when (symbolp s2) (setq s2 (symbol-name s2)))
(if (stringp s2)
@ -1204,7 +1235,8 @@ Use special code 0 to cancel this operation.")
(set-break-env))
(defun set-break-env ()
(setq *break-env* (ihs-env *ihs-current*)))
(setq *break-lexenv* (ihs-lex *ihs-current*))
(setq *break-locals* (ihs-lcl *ihs-current*)))
(defun ihs-search (string unrestricted &optional (start (si::ihs-top)))
(do ((ihs start (si::ihs-prev ihs)))
@ -1300,7 +1332,8 @@ Use the following functions to directly access ECL stacks.
Invocation History Stack:
(SYS:IHS-TOP) Returns the index of the TOP of the IHS.
(SYS:IHS-FUN i) Returns the function of the i-th entity in IHS.
(SYS:IHS-ENV i)
(SYS:IHS-LEX i) Returns the lexical environment of the i-th entry in IHS.
(SYS:IHS-LCL i) Returns the local environment of the i-th entry in IHS.
(SYS:IHS-PREV i)
(SYS:IHS-NEXT i)
@ -1413,7 +1446,8 @@ package."
(*break-condition* condition)
(*break-level* (1+ *break-level*))
(break-level *break-level*)
(*break-env* nil))
(*break-locals* nil)
(*break-lexenv* nil))
(check-default-debugger-runaway)
#+threads
;; We give our process priority for grabbing the console.