2 /* Interpreter for the Kernel programming language*/
4 /*_ . Credits and License */
6 Copyright (C) 2010,2011 Tom Breton (Tehom)
8 This program is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>.
24 #include "klink-private.h"
29 #define snprintf _snprintf
48 # define stricmp strcasecmp
52 /* Used for documentation purposes, to signal functions in 'interface' */
60 stricmp (const char *s1
, const char *s2
)
76 #endif /* __APPLE__ */
92 /*_ . Configuration */
94 #define banner "Klink 0.0\n"
97 # define prompt "klink> "
101 # define InitFile "init.krn"
104 /*_ , Internal declarations */
106 /*_ , Name-mangling */
107 #define KEY(C_NAME) _k_key_##C_NAME
108 #define DESTR_NAME(C_NAME) _k_destructure_##C_NAME
109 #define OPER(C_NAME) _k_oper_##C_NAME
110 #define APPLICATIVE(C_NAME) _k_appl_##C_NAME
111 #define CHAIN_NAME(C_NAME) _k_chain_##C_NAME
112 #define CHKARRAY(C_NAME) _k_chkvec_##C_NAME
114 /*_ , For forward declarations of combiners */
115 #define FORWARD_DECL_CFUNC(LINKAGE,SUFFIX,C_NAME) \
116 LINKAGE KERNEL_FUN_SIG_##SUFFIX (C_NAME); \
117 kt_boxed_cfunc OPER(C_NAME)
119 #define FORWARD_DECL_PRED(LINKAGE,C_NAME) \
120 FORWARD_DECL_CFUNC(LINKAGE,b00a1,C_NAME)
122 #define FORWARD_DECL_T_PRED(LINKAGE,C_NAME) \
123 LINKAGE kt_boxed_T OPER(C_NAME)
125 #define FORWARD_DECL_CHAIN(LINKAGE,C_NAME) \
126 LINKAGE kt_boxed_vector OPER(C_NAME)
128 #define FORWARD_DECL_APPLICATIVE(LINKAGE,SUFFIX,C_NAME) \
129 FORWARD_DECL_CFUNC(LINKAGE,SUFFIX,C_NAME); \
130 kt_boxed_encap APPLICATIVE(C_NAME); \
134 /* No noun/number agreement for WITH_1_ARGS because I prefer name
136 #define WITH_1_ARGS(A1) \
138 #define WITH_2_ARGS(A1,A2) \
139 WITH_1_ARGS(A1), A2 = arg2
140 #define WITH_3_ARGS(A1,A2,A3) \
141 WITH_2_ARGS(A1,A2), A3 = arg3
142 #define WITH_4_ARGS(A1,A2,A3,A4) \
143 WITH_3_ARGS(A1,A2,A3), A4 = arg4
144 #define WITH_5_ARGS(A1,A2,A3,A4,A5) \
145 WITH_4_ARGS(A1,A2,A3,A4), A5 = arg5
146 /*_ , WITH_REPORTER */
147 #define WITH_REPORTER(SC) \
148 sc_or_null _err_reporter = (SC)
149 /*_ , Defining sub-T types */
151 #define VEC_DEF_FROM_ARRAY(ARRAY_NAME) \
153 sizeof(ARRAY_NAME)/sizeof(ARRAY_NAME[0]), \
157 #define DEF_VEC(T_ENUM, NAME, ARRAY_NAME) \
158 kt_boxed_vector NAME = \
161 VEC_DEF_FROM_ARRAY (ARRAY_NAME), \
164 /*_ , Checking type */
165 /*_ . Certain destructurers and type checks */
166 #define K_ANY REF_OPER(is_any)
167 #define K_NO_TYPE REF_KEY(K_TYCH_NO_TYPE)
168 #define K_ANY_SINGLETON REF_OBJ(_K_any_singleton)
170 /*_ . Internal: Arrays to be in typechecks and destructurers */
171 /* Elements of this array should not call Kernel - should be T_NO_K */
172 /* $$IMPROVE ME Check that when registering combiners */
173 #define SIG_CHKARRAY(C_NAME) pko CHKARRAY(C_NAME)[]
174 /*_ . Boxed destructurers */
175 #define REF_DESTR(C_NAME) REF_OBJ(DESTR_NAME(C_NAME))
176 #define DESTR_DEF_FROM_ARRAY(ARRAY_NAME) \
177 { VEC_DEF_FROM_ARRAY (ARRAY_NAME), -1, }
179 #define DEF_DESTR(NAME,ARRAY_NAME) \
180 kt_boxed_destr_list NAME = \
182 T_DESTRUCTURE | T_IMMUTABLE | T_NO_K, \
183 DESTR_DEF_FROM_ARRAY(ARRAY_NAME), \
186 /* DEF_VEC(T_DESTRUCTURE | T_IMMUTABLE | T_NO_K, NAME, ARRAY_NAME) */
188 #define DEF_SIMPLE_DESTR(C_NAME) \
189 DEF_DESTR(DESTR_NAME(C_NAME), CHKARRAY(C_NAME))
194 /* Awkward because we both declare stuff and assign stuff. */
195 #define ALLOC_BOX(NAME,T_ENUM,BOXTYPE) \
196 typedef BOXTYPE _TT; \
197 _TT * NAME = GC_MALLOC(sizeof(_TT)); \
200 /* ALLOC_BOX_PRESUME defines the following:
201 pbox - a pointer to the box
202 pdata - a pointer to the box's contents
204 #define ALLOC_BOX_PRESUME(TYPE,T_ENUM) \
206 ALLOC_BOX(pbox,T_ENUM,BOX_OF(TYPE)); \
207 pdata = &(pbox)->data
211 #define WITH_BOX_TYPE(NAME,P) \
212 _kt_tag * NAME = &((kt_boxed_any *)(P))->type;
215 /* This could mostly be an inlined function, but it wouldn't know
217 #define WITH_UNBOXED_RAW(P,NAME,TYPE,BOXTYPE) \
220 typedef BOXTYPE _TT; \
221 _TT * _pbox = (_TT *)(P); \
222 NAME = &_pbox->data; \
225 /*_ , Entry points */
226 #define WITH_UNBOXED_UNSAFE(NAME,TYPE,P) \
227 WITH_UNBOXED_RAW(P,NAME,TYPE,BOX_OF(TYPE))
230 /* WITH_PSYC_UNBOXED defines the following:
231 pdata - a pointer to the box's contents
233 #define WITH_PSYC_UNBOXED(TYPE,P,T_ENUM,SC) \
234 assert_type(SC,(P),T_ENUM); \
235 WITH_UNBOXED_UNSAFE(pdata,TYPE,P)
239 #define REF_KEY(NAME) REF_OBJ(KEY(NAME))
241 #define BOX_OF_VOID(NAME) \
242 kt_boxed_void KEY(NAME) = { T_KEY | T_IMMUTABLE }; \
243 pko NAME = REF_KEY(NAME)
246 /* All operatives use this, regardless whether they are cfuncs,
248 #define REF_OPER(C_NAME) REF_OBJ(OPER(C_NAME))
251 #define DEF_CFUNC_RAW(NAME,SUFFIX,C_NAME,DESTR,XTRA_FLAGS) \
252 RGSTR(all-builtins,"C-" #C_NAME, REF_OBJ (NAME)) \
253 kt_boxed_cfunc NAME = \
254 { T_CFUNC | T_IMMUTABLE | XTRA_FLAGS, \
255 {{C_NAME}, klink_ftype_##SUFFIX, DESTR, 0}};
257 #define DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME, DESTR,XTRA_FLAGS) \
258 DEF_CFUNC_RAW(OPER(C_NAME),SUFFIX,C_NAME, DESTR,XTRA_FLAGS)
260 #define DEF_CFUNC(SUFFIX,C_NAME,DESTR,XTRA_FLAGS) \
261 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
262 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,DESTR,XTRA_FLAGS); \
263 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
265 #define DEF_SIMPLE_CFUNC(SUFFIX,C_NAME,XTRA_FLAGS) \
266 DEF_SIMPLE_DESTR(C_NAME); \
267 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
268 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,REF_DESTR(C_NAME),XTRA_FLAGS); \
269 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
271 /*_ . Applicatives */
272 #define REF_APPL(C_NAME) REF_OBJ(APPLICATIVE(C_NAME))
274 #define DEF_BOXED_APPLICATIVE(C_NAME,FF) \
275 kt_boxed_encap APPLICATIVE (C_NAME) = \
276 { T_ENCAP | T_IMMUTABLE, \
277 {REF_KEY(K_APPLICATIVE), FF}};
279 #define DEF_APPLICATIVE_W_DESTR(SUFFIX,C_NAME,DESTR,XTRA_FLAGS,RG,K_NAME) \
280 RGSTR(RG,K_NAME, REF_APPL(C_NAME)) \
281 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
282 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,DESTR,XTRA_FLAGS); \
283 DEF_BOXED_APPLICATIVE(C_NAME, REF_OPER (C_NAME)); \
284 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
286 #define DEF_SIMPLE_APPLICATIVE(SUFFIX,C_NAME,XTRA_FLAGS,RG,K_NAME) \
287 RGSTR(RG,K_NAME, REF_APPL(C_NAME)) \
288 DEF_SIMPLE_DESTR(C_NAME); \
289 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
290 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,REF_DESTR(C_NAME),XTRA_FLAGS); \
291 DEF_BOXED_APPLICATIVE(C_NAME, REF_OPER (C_NAME)); \
292 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
294 /*_ . Abbreviations for predicates */
295 /* The underlying C function takes the whole value as its sole arg.
296 Above that, in init.krn an applicative wrapper applies it over a
297 list, using `every?'.
299 #define DEF_SIMPLE_PRED(C_NAME,XTRA_FLAGS,RG,K_NAME) \
300 RGSTR(RG,K_NAME, REF_OPER(C_NAME)) \
301 DEF_CFUNC(b00a1,C_NAME,K_ANY_SINGLETON,XTRA_FLAGS)
303 /* The cfunc is there just to be exported for C use. */
304 #define DEF_T_PRED(C_NAME,T_ENUM,RG,K_NAME) \
305 RGSTR(RG,K_NAME, REF_OPER(C_NAME)) \
306 kt_boxed_T OPER(C_NAME) = \
307 { T_TYPEP | T_IMMUTABLE | T_NO_K, {T_ENUM}}; \
308 int C_NAME(pko p) { return is_type(p,T_ENUM); }
311 /*_ . Curried Functions */
313 #define DEF_BOXED_CURRIED(CURRY_NAME,DECURRIER,ARGS,NEXT) \
314 RGSTR(all-builtins,"C-" #CURRY_NAME, REF_OBJ (CURRY_NAME)) \
315 kt_boxed_curried CURRY_NAME = \
316 { T_CURRIED | T_IMMUTABLE, \
317 {DECURRIER, ARGS, NEXT, 0}};
319 #define DEF_BOXED_PAIR(C_NAME,CAR,CDR) \
320 boxed_vec2 C_NAME = \
321 { T_PAIR | T_IMMUTABLE, {CAR, CDR, }}
324 #define DEF_LISTSTAR2 DEF_BOXED_PAIR
326 #define DEF_LISTSTAR3(C_NAME,A1,A2,A3) \
327 DEF_BOXED_PAIR(C_NAME##__1,A2,A3); \
328 DEF_BOXED_PAIR(C_NAME,A1,REF_OBJ(C_NAME##__1))
330 #define DEF_LIST1(C_NAME,A1) DEF_LISTSTAR2(C_NAME,A1, REF_KEY(K_NIL))
331 #define DEF_LIST2(C_NAME,A1,A2) DEF_LISTSTAR3(C_NAME,A1,A2,REF_KEY(K_NIL))
333 /*_ , Building objects in C */
334 #define ANON_OBJ( TYPE, X ) \
335 (((BOX_OF( TYPE )[]) { X })[0])
337 /* Middle is the same as ANON_OBJ but we can't just use that because
338 of expansion issues */
339 #define ANON_REF( TYPE, X ) \
340 REF_OBJ((((BOX_OF( TYPE )[]) { X })[0]))
342 #define PAIR_DEF( CAR, CDR ) \
343 { T_PAIR | T_IMMUTABLE, { CAR, CDR, }, }
345 #define ANON_PAIR( CAR, CDR ) \
346 ANON_REF(kt_vec2, PAIR_DEF( CAR, CDR ))
348 #define INT_DEF( N ) \
349 { T_NUMBER | T_IMMUTABLE, { 1, { N }, }, }
352 /*_ , Building lists in C */
353 /*_ . Anonymous lists */
355 #define ANON_LISTSTAR2(A1, A2) \
358 #define ANON_LISTSTAR3(A1, A2, A3) \
359 ANON_PAIR(A1, ANON_LISTSTAR2(A2, A3))
361 #define ANON_LISTSTAR4(A1, A2, A3, A4) \
362 ANON_PAIR(A1, ANON_LISTSTAR3(A2, A3, A4))
365 #define ANON_LIST1(A1) \
366 ANON_LISTSTAR2(A1, REF_KEY(K_NIL))
368 #define ANON_LIST2(A1, A2) \
369 ANON_PAIR(A1, ANON_LIST1(A2))
371 #define ANON_LIST3(A1, A2, A3) \
372 ANON_PAIR(A1, ANON_LIST2(A2, A3))
374 #define ANON_LIST4(A1, A2, A3, A4) \
375 ANON_PAIR(A1, ANON_LIST3(A2, A3, A4))
377 #define ANON_LIST5(A1, A2, A3, A4, A5) \
378 ANON_PAIR(A1, ANON_LIST4(A2, A3, A4, A5))
380 #define ANON_LIST6(A1, A2, A3, A4, A5, A6) \
381 ANON_PAIR(A1, ANON_LIST5(A2, A3, A4, A5, A6))
384 /*_ . Dynamic lists */
386 #define LISTSTAR2(A1, A2) \
388 #define LISTSTAR3(A1, A2, A3) \
389 cons (A1, LISTSTAR2(A2, A3))
390 #define LISTSTAR4(A1, A2, A3, A4) \
391 cons (A1, LISTSTAR3(A2, A3, A4))
397 #define LIST2(A1, A2) \
398 cons (A1, LIST1 (A2))
399 #define LIST3(A1, A2, A3) \
400 cons (A1, LIST2 (A2, A3))
401 #define LIST4(A1, A2, A3, A4) \
402 cons (A1, LIST3 (A2, A3, A4))
403 #define LIST5(A1, A2, A3, A4, A5) \
404 cons (A1, LIST4 (A2, A3, A4, A5))
405 #define LIST6(A1, A2, A3, A4, A5, A6) \
406 cons (A1, LIST5 (A2, A3, A4, A5, A6))
408 /*_ , Kernel continuation macros */
409 /*_ . W/o decurrying */
410 #define CONTIN_0_RAW(C_NAME,SC) \
411 klink_push_cont((SC), (C_NAME))
412 #define CONTIN_0(OPER_NAME,SC) \
413 klink_push_cont((SC), REF_OPER (OPER_NAME))
416 /* The use of REF_OPER requires these to be macros. */
418 #define CONTIN_1R(DECURRIER,C_NAME,SC,ARGS) \
419 klink_push_cont((SC), \
420 mk_curried(DECURRIER, ARGS, REF_OPER (C_NAME)))
422 #define CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,ARG2) \
423 CONTIN_1R(DECURRIER,C_NAME,SC,cons(ARG1,ARG2))
425 #define CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3) \
426 CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,cons(ARG2,ARG3))
428 #define CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4) \
429 CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,cons(ARG3,ARG4))
431 #define CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5) \
432 CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,cons(ARG4,ARG5))
434 #define CONTIN_6R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5,ARG6) \
435 CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,cons(ARG5,ARG6))
439 #define CONTIN_1(DECURRIER,C_NAME,SC,ARG1) \
440 CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,K_NIL)
442 #define CONTIN_2(DECURRIER,C_NAME,SC,ARG1,ARG2) \
443 CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,K_NIL)
445 #define CONTIN_3(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3) \
446 CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,K_NIL)
448 #define CONTIN_4(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4) \
449 CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,K_NIL)
451 #define CONTIN_5(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5) \
452 CONTIN_6R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5,K_NIL)
455 #define kernel_bool(tf) ((tf) ? K_T : K_F)
457 /*_ , Control macros */
459 /* These never return because _klink_error_1 longjmps. */
460 /* $$IMPROVE ME If GCC is used or C99 is available, use __func__ as the function name. */
461 #define KERNEL_ERROR_1(sc,s, a) { _klink_error_1(sc,s,a); return 0; }
462 #define KERNEL_ERROR_0(sc,s) { _klink_error_1(sc,s,0); return 0; }
464 /*_ . Enumerations */
465 /*_ , The port types & flags */
480 typedef enum klink_token
498 /*_ , List metrics */
507 typedef int int4
[lm_max
];
509 /*_ . Struct definitions */
512 typedef BOX_OF (kt_cfunc
)
519 /* Object identity lets us compare instances. */
524 typedef BOX_OF (kt_encap
)
527 /*_ , Curried calls */
529 typedef pko (* decurrier_f
) (klink
* sc
, pko args
, pko value
);
534 decurrier_f decurrier
;
540 typedef BOX_OF (kt_curried
)
543 /*_ , T_typep calls */
550 typedef BOX_OF(typep_t
)
584 typedef BOX_OF(kt_vector
)
586 /*_ , Destructurer */
587 /*_ , kt_destr_list */
594 typedef BOX_OF(kt_destr_list
)
598 /*_ , Initialization */
599 static void klink_setup_error_cont (klink
* sc
);
600 static void klink_cycle_restarting (klink
* sc
, pko combiner
);
601 static int klink_cycle_no_restart (klink
* sc
, pko combiner
);
602 static void _klink_cycle (klink
* sc
);
605 /*_ , Error handling */
606 static void _klink_error_1 (klink
* sc
, const char *s
, pko a
);
607 /*_ . Stack control */
608 static int klink_pop_cont (klink
* sc
);
611 static pko
klink_call_cfunc (klink
* sc
, pko functor
, pko env
, pko args
);
612 FORWARD_DECL_CFUNC (static, ps0a2
, k_resume_to_cfunc
);
616 mk_load_ix (int x
, int y
);
621 mk_store (pko data
, int depth
);
625 call_curried(klink
* sc
, pko curried
, pko value
);
627 /*_ , Top level operatives */
628 FORWARD_DECL_APPLICATIVE(static,ps0a0
,kernel_repl
);
629 FORWARD_DECL_APPLICATIVE(static,ps0a0
,kernel_rel
);
630 FORWARD_DECL_APPLICATIVE(static,ps0a1
,kernel_internal_eval
);
633 static INLINE pko
oblist_find_by_name (const char *name
);
634 static pko
oblist_add_by_name (const char *name
);
637 static pko
mk_number (num n
);
639 static num
num_add (num a
, num b
);
640 static num
num_mul (num a
, num b
);
641 static num
num_div (num a
, num b
);
642 static num
num_intdiv (num a
, num b
);
643 static num
num_sub (num a
, num b
);
644 static num
num_rem (num a
, num b
);
645 static num
num_mod (num a
, num b
);
646 static int num_eq (num a
, num b
);
647 static int num_gt (num a
, num b
);
648 static int num_ge (num a
, num b
);
649 static int num_lt (num a
, num b
);
650 static int num_le (num a
, num b
);
653 static double round_per_R5RS (double x
);
656 /*_ , Lists and vectors */
657 FORWARD_DECL_PRED (extern, is_finite_list
);
658 FORWARD_DECL_PRED (extern, is_countable_list
);
659 extern int list_length (pko a
);
660 static pko
reverse (klink
* sc
, pko a
);
661 static pko
unsafe_v2reverse_in_place (pko term
, pko list
);
662 static pko
append (klink
* sc
, pko a
, pko b
);
664 static pko
alloc_basvector (int len
, _kt_tag t_enum
);
665 static void unsafe_basvector_fill (pko vec
, pko obj
);
667 static pko
mk_vector (int len
, pko fill
);
668 INTERFACE
static void fill_vector (pko vec
, pko obj
);
669 INTERFACE
static pko
vector_elem (pko vec
, int ielem
);
670 INTERFACE
static void set_vector_elem (pko vec
, int ielem
, pko a
);
671 INTERFACE
static int vector_len (pko vec
);
673 get_list_metrics_aux (pko a
, int4 presults
);
676 k_counted_map_car(klink
* sc
, int count
, pko list
, _kt_tag t_enum
);
678 k_counted_map_cdr(klink
* sc
, int count
, pko list
, _kt_tag t_enum
);
681 static pko
port_from_filename (const char *fn
, int prop
);
682 static pko
port_from_file (FILE *, int prop
);
683 static pko
port_from_string (char *start
, char *past_the_end
, int prop
);
684 static void port_close (pko p
, int flag
);
685 static void port_finalize_file(GC_PTR obj
, GC_PTR client_data
);
686 static port
*port_rep_from_filename (const char *fn
, int prop
);
687 static port
*port_rep_from_file (FILE *, int prop
);
688 static port
*port_rep_from_string (char *start
, char *past_the_end
, int prop
);
689 static void port_close_port (port
* pt
, int flag
);
690 INLINE port
* portvalue (pko p
);
691 static int basic_inchar (port
* pt
);
692 static int inchar (port
*pt
);
693 static void backchar (port
* pt
, int c
);
695 FORWARD_DECL_APPLICATIVE (extern,ps0a1
, mk_typecheck
);
696 FORWARD_DECL_APPLICATIVE (extern,ps0a1
, mk_destructurer
);
697 FORWARD_DECL_CFUNC (extern, ps0a5
, destructure_resume
);
698 FORWARD_DECL_PRED (extern, is_any
);
699 FORWARD_DECL_T_PRED (extern, is_environment
);
700 FORWARD_DECL_PRED (extern, is_integer
);
702 FORWARD_DECL_CFUNC (extern,ps0a2
,handle_promise_result
);
703 FORWARD_DECL_CFUNC (extern, ps0a1
, mk_promise_lazy
);
704 FORWARD_DECL_APPLICATIVE (extern, ps0a1
, force
);
705 /*_ , About encapsulation */
706 FORWARD_DECL_CFUNC (static,b00a2
, is_encap
);
707 FORWARD_DECL_CFUNC (static,p00a2
, mk_encap
);
708 FORWARD_DECL_CFUNC (static,ps0a2
, unencap
);
709 FORWARD_DECL_APPLICATIVE (extern,p00a0
, mk_encapsulation_type
);
711 /*_ , About combiners per se */
712 FORWARD_DECL_PRED(extern,is_combiner
);
713 /*_ , About operatives */
714 FORWARD_DECL_PRED(extern,is_operative
);
716 schedule_rv_list(klink
* sc
, pko list
);
718 /*_ , About applicatives */
720 FORWARD_DECL_PRED(extern,is_applicative
);
721 FORWARD_DECL_APPLICATIVE(extern,p00a1
,wrap
);
722 FORWARD_DECL_APPLICATIVE(extern,ps0a1
,unwrap
);
723 FORWARD_DECL_APPLICATIVE(extern,p00a1
,unwrap_all
);
725 /*_ , About currying */
730 static pko
dcrry_2A01VLL (klink
* sc
, pko args
, pko value
);
731 static pko
dcrry_3A01dotVLL (klink
* sc
, pko args
, pko value
);
732 static pko
dcrry_2CA01VLLA02 (klink
* sc
, pko args
, pko value
);
733 /* May not be needed */
734 static pko
dcrry_3A01A02VLL (klink
* sc
, pko args
, pko value
);
735 static pko
dcrry_2ALLVLL (klink
* sc
, pko args
, pko value
);
736 static pko
dcrry_2ALLV01 (klink
* sc
, pko args
, pko value
);
738 static pko
dcrry_NdotALL (klink
* sc
, pko args
, pko value
);
739 #define dcrry_1A01 dcrry_NdotALL
740 #define dcrry_1dotALL dcrry_NdotALL
741 #define dcrry_2dotALL dcrry_NdotALL
742 #define dcrry_3dotALL dcrry_NdotALL
743 #define dcrry_4dotALL dcrry_NdotALL
745 static pko
dcrry_1ALL (klink
* sc
, pko args
, pko value
);
747 static pko
dcrry_5ALLdotVLL (klink
* sc
, pko args
, pko value
);
748 #define dcrry_3ALLdotVLL dcrry_5ALLdotVLL
750 static pko
dcrry_NVLLdotALL (klink
* sc
, pko args
, pko value
);
751 #define dcrry_2VLLdotALL dcrry_NVLLdotALL
752 #define dcrry_3VLLdotALL dcrry_NVLLdotALL
753 #define dcrry_4VLLdotALL dcrry_NVLLdotALL
754 #define dcrry_5VLLdotALL dcrry_NVLLdotALL
756 static pko
dcrry_1VLL (klink
* sc
, pko args
, pko value
);
757 static pko
dcrry_NCVLLA01dotAX1 (klink
* sc
, pko args
, pko value
);
758 #define dcrry_2CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
759 #define dcrry_3CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
760 #define dcrry_4CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
761 #define dcrry_5CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
763 FORWARD_DECL_CFUNC(static,ps0a4
,values_pair
);
766 /*_ , Of Kernel evaluation */
767 /*_ . Public functions */
768 FORWARD_DECL_APPLICATIVE(extern,ps0a2
,kernel_eval
);
769 FORWARD_DECL_CFUNC (extern,ps0a3
, vau_1
);
770 /*_ . Other signatures */
771 FORWARD_DECL_APPLICATIVE(static,ps0a3
,kernel_eval_aux
);
772 FORWARD_DECL_APPLICATIVE(static,ps0a3
,kernel_mapeval
);
773 FORWARD_DECL_APPLICATIVE(static,ps0a3
, kernel_mapand_aux
);
774 FORWARD_DECL_APPLICATIVE(extern,ps0a2
, kernel_mapand
);
775 FORWARD_DECL_APPLICATIVE(static,ps0a5
,eval_vau
);
779 FORWARD_DECL_APPLICATIVE(static,ps0a0
,kernel_read_internal
);
780 FORWARD_DECL_CFUNC(extern,ps0a0
,kernel_read_sexp
);
781 FORWARD_DECL_CFUNC(static,ps0a2
,kernel_read_list
);
782 FORWARD_DECL_CFUNC(static,ps0a2
,kernel_treat_dotted_list
);
783 FORWARD_DECL_CFUNC(static,ps0a1
,kernel_treat_qquoted_vec
);
785 static INLINE
int is_one_of (char *s
, int c
);
786 static long binary_decode (const char *s
);
787 static char *readstr_upto (klink
* sc
, char *delim
);
788 static pko
readstrexp (klink
* sc
);
789 static INLINE
int skipspace (klink
* sc
);
790 static int token (klink
* sc
);
791 static pko
mk_atom (klink
* sc
, char *q
);
792 static pko
mk_sharp_const (char *name
);
795 /* $$IMPROVE ME These should mostly be just operatives. */
796 FORWARD_DECL_APPLICATIVE(static,ps0a2
,kernel_print_sexp
);
797 FORWARD_DECL_APPLICATIVE(static,ps0a3
,kernel_print_sexp_aux
);
798 FORWARD_DECL_APPLICATIVE(static,ps0a3
,kernel_print_list
);
799 FORWARD_DECL_APPLICATIVE(static,ps0a4
,kernel_print_vec_from
);
800 static kt_boxed_curried k_print_terminate_list
;
802 static void printslashstring (klink
* sc
, char *s
, int len
);
803 static void atom2str (klink
* sc
, pko l
, char **pp
, int *plen
);
804 static void printatom (klink
* sc
, pko l
);
806 /*_ , Stack & continuations */
807 /*_ . Continuations */
808 static pko
mk_continuation (_kt_spagstack d
);
809 static void klink_push_cont (klink
* sc
, pko combiner
);
811 klink_push_cont_aux (_kt_spagstack old_frame
, pko ff
, pko env
);
812 FORWARD_DECL_APPLICATIVE(extern,p00a1
,continuation_to_applicative
);
813 FORWARD_DECL_CFUNC(static,vs0a2
,invoke_continuation
);
814 FORWARD_DECL_CFUNC(static,ps0a2
,continue_abnormally
);
815 static _kt_spagstack special_dynxtnt
816 (_kt_spagstack outer
, _kt_spagstack prox_dest
, pko envir
);
820 /*_ . Dynamic bindings */
821 static void klink_push_dyn_binding (klink
* sc
, pko id
, pko value
);
822 static pko
klink_find_dyn_binding(klink
* sc
, pko id
);
824 struct stack_profiling
;
826 k_profiling_done_frame(klink
* sc
, struct stack_profiling
* profile
);
829 get_nth_arg( _kt_spagstack frame
, int n
);
831 push_arg (klink
* sc
, pko value
);
833 /*_ , Environment and defining */
834 FORWARD_DECL_CFUNC(static,vs0a3
,kernel_define_tree
);
835 FORWARD_DECL_CFUNC(extern,p00a3
,kernel_define
);
836 FORWARD_DECL_CFUNC(extern,ps0a2
,eval_define
);
837 FORWARD_DECL_CFUNC(extern,ps0a3
,set
);
838 FORWARD_DECL_CFUNC(static,ps0a4
,set_aux
);
840 static pko
find_slot_in_env (pko env
, pko sym
, int all
);
841 static INLINE pko
slot_value_in_env (pko slot
);
842 static INLINE
void set_slot_in_env (pko slot
, pko value
);
844 reverse_find_slot_in_env_aux (pko env
, pko value
);
845 /*_ . Standard environment */
846 FORWARD_DECL_CFUNC(extern,p00a0
, mk_std_environment
);
847 FORWARD_DECL_APPLICATIVE (extern,ps0a0
, get_current_environment
);
848 /*_ , Misc kernel functions */
850 FORWARD_DECL_CFUNC(extern,ps0a1
,arg1
);
851 FORWARD_DECL_APPLICATIVE(extern,ps0a1
,val2val
)
853 /*_ , Error functions */
854 FORWARD_DECL_CFUNC(static,ps0a1
,kernel_err
);
855 FORWARD_DECL_CFUNC(static,ps0a1
,kernel_err_x
);
857 /*_ , For DL if present */
859 FORWARD_DECL_APPLICATIVE(extern,ps0a1
,klink_load_ext
);
863 static pko
mk_symbol_obj (const char *name
);
866 static char *store_string (int len
, const char *str
, char fill
);
868 /*_ . Object declarations */
870 /* These objects are declared here because some macros use them, but
871 should not be directly used. */
872 /* $$IMPROVE ME Somehow hide these better without hiding it from the
873 applicative & destructure macros. */
874 kt_boxed_void
KEY(K_APPLICATIVE
);
875 kt_boxed_void
KEY(K_NIL
);
877 kt_boxed_destr_list _K_any_singleton
;
878 /*_ , Pointers to base environments */
879 static pko print_lookup_env
;
880 static pko all_builtins_env
;
881 static pko ground_env
;
882 static pko typecheck_env_syms
;
884 static pko print_lookup_unwraps
;
885 static pko print_lookup_to_xary
;
888 /*_ . Low-level treating T-types */
894 WITH_BOX_TYPE(ptype
,p
);
895 return *ptype
& T_MASKTYPE
;
900 is_type (pko p
, int T_index
)
902 return _get_type (p
) == T_index
;
904 /*_ . type_err_string */
906 type_err_string(_kt_tag t_enum
)
911 return "Must be a string";
913 return "Must be a number";
915 return "Must be a symbol";
917 return "Must be a pair";
919 return "Must be a character";
921 return "Must be a port";
923 return "Must be an encapsulation";
925 return "Must be a continuation";
927 return "Must be an environment";
929 return "Must be a recurrence table";
930 case T_RECUR_TRACKER
:
931 return "Must be a recurrence tracker";
933 return "Must be a destructure result";
935 /* Left out types that shouldn't be distinguished in Kernel. */
936 return "Error message for this type needs to be coded";
940 /* If sc is given, it's a assertion making a Kernel error, otherwise
941 it's a C assertion. */
943 assert_type (sc_or_null sc
, pko p
, _kt_tag t_enum
)
945 if(sc
&& (_get_type(p
) != (t_enum
)))
947 const char * err_msg
= type_err_string(t_enum
);
948 _klink_error_1(sc
,err_msg
,p
);
949 return; /* NOTREACHED */
952 { assert (_get_type(p
) == (t_enum
)); }
960 WITH_BOX_TYPE(ptype
,p
);
961 return *ptype
& T_IMMUTABLE
;
964 INTERFACE INLINE
void
967 WITH_BOX_TYPE(ptype
,p
);
968 *ptype
|= T_IMMUTABLE
;
971 /* If sc is given, it's a assertion making a Kernel error, otherwise
972 it's a C assertion. */
974 assert_mutable (sc_or_null sc
, pko p
)
976 WITH_BOX_TYPE(ptype
,p
);
977 if(sc
&& (*ptype
& T_IMMUTABLE
))
979 _klink_error_1(sc
,"Attempt to mutate immutable object",p
);
983 { assert(!(*ptype
& T_IMMUTABLE
)); }
986 #define DEBUG_assert_mutable assert_mutable
988 /*_ , No-call-Kernel */
992 WITH_BOX_TYPE(ptype
,p
);
993 return *ptype
& T_NO_K
;
996 SIG_CHKARRAY(eqp
) = { K_ANY
, K_ANY
, };
997 DEF_SIMPLE_APPLICATIVE(p00a2
,eqp
,T_NO_K
,ground
,"eq?")
1000 return kernel_bool(a
== b
);
1002 /*_ . Low-level object types */
1003 /*_ , vec2 (Low lists) */
1010 typedef BOX_OF(kt_vec2
) boxed_vec2
;
1012 /*_ . Type assert */
1013 /* $$IMPROVE ME Disable this if DEBUG_LEVEL is low */
1014 void assert_T_is_v2(_kt_tag t_enum
)
1016 t_enum
&= T_MASKTYPE
;
1019 || t_enum
== T_ENV_PAIR
1020 || t_enum
== T_ENV_FRAME
1021 || t_enum
== T_PROMISE
1022 || t_enum
== T_DESTR_RESULT
1028 v2cons (_kt_tag t_enum
, pko a
, pko b
)
1030 ALLOC_BOX_PRESUME (kt_vec2
, t_enum
);
1031 pbox
->data
._car
= a
;
1032 pbox
->data
._cdr
= b
;
1033 return PTR2PKO(pbox
);
1036 /*_ . Unsafe operations (Typechecks can be disabled) */
1038 unsafe_v2car (pko p
)
1040 assert_T_is_v2(_get_type(p
));
1041 WITH_UNBOXED_UNSAFE(pdata
,kt_vec2
,p
);
1046 unsafe_v2cdr (pko p
)
1048 assert_T_is_v2(_get_type(p
));
1049 WITH_UNBOXED_UNSAFE(pdata
,kt_vec2
,p
);
1054 unsafe_v2set_car (pko p
, pko q
)
1056 assert_T_is_v2(_get_type(p
));
1057 DEBUG_assert_mutable(0,p
);
1058 WITH_UNBOXED_UNSAFE(pdata
,kt_vec2
,p
);
1064 unsafe_v2set_cdr (pko p
, pko q
)
1066 assert_T_is_v2(_get_type(p
));
1067 DEBUG_assert_mutable(0,p
);
1068 WITH_UNBOXED_UNSAFE(pdata
,kt_vec2
,p
);
1073 /*_ . Checked operations */
1075 v2car (sc_or_null err_reporter
, _kt_tag t_enum
, pko p
)
1077 assert_type(err_reporter
,p
,t_enum
);
1078 return unsafe_v2car(p
);
1082 v2cdr (sc_or_null err_reporter
, _kt_tag t_enum
, pko p
)
1084 assert_type(err_reporter
,p
,t_enum
);
1085 return unsafe_v2cdr(p
);
1089 v2set_car (sc_or_null err_reporter
, _kt_tag t_enum
, pko p
, pko q
)
1091 assert_type(err_reporter
,p
,t_enum
);
1092 assert_mutable(err_reporter
,p
);
1093 unsafe_v2set_car(p
,q
);
1098 v2set_cdr (sc_or_null err_reporter
, _kt_tag t_enum
, pko p
, pko q
)
1100 assert_type(err_reporter
,p
,t_enum
);
1101 assert_mutable(err_reporter
,p
);
1102 unsafe_v2set_cdr(p
,q
);
1106 /*_ . "Psychic" macros */
1107 #define WITH_V2(T_ENUM) \
1108 _kt_tag _t_enum = T_ENUM; \
1109 assert_T_is_v2(_t_enum)
1111 /* These expect WITH_REPORTER and WITH_V2 to be used in scope. */
1112 #define PSYC_v2cons(A,B) v2cons (_t_enum, (A), (B))
1113 #define PSYC_v2car(X) v2car (_err_reporter, _t_enum, (X))
1114 #define PSYC_v2cdr(X) v2cdr (_err_reporter, _t_enum, (X))
1115 #define PSYC_v2set_car(A,B) v2set_car (_err_reporter, _t_enum, (A), (B))
1116 #define PSYC_v2set_cdr(A,B) v2set_cdr (_err_reporter, _t_enum, (A), (B))
1118 /*_ . Container macros */
1120 /* This expects _EXPLORE_FUNC to be defined as a macro taking OBJ,
1121 inspecting it but not mutating it. */
1122 #define EXPLORE_v2(OBJ) \
1124 WITH_UNBOXED_UNSAFE(pdata,kt_vec2,OBJ); \
1125 _EXPLORE_FUNC(pdata->_car); \
1126 _EXPLORE_FUNC(pdata->_cdr); \
1129 /* #define _EXPLORE_FUNC(X) trace_tree_cycles(X, p_cycles_data) */
1131 /*_ . Low list operations */
1132 /*_ , v2list_star */
1133 pko
v2list_star(sc_or_null sc
, pko d
, _kt_tag t_enum
)
1138 pko cdr_d
= PSYC_v2cdr (d
);
1141 return PSYC_v2car (d
);
1143 p
= PSYC_v2cons (PSYC_v2car (d
), cdr_d
);
1146 while (PSYC_v2cdr (PSYC_v2cdr (p
)) != K_NIL
)
1148 pko cdr_p
= PSYC_v2cdr (p
);
1149 d
= PSYC_v2cons (PSYC_v2car (p
), cdr_p
);
1150 if (PSYC_v2cdr (cdr_p
) != K_NIL
)
1155 PSYC_v2set_cdr (p
, PSYC_v2car (PSYC_v2cdr (p
)));
1159 /*_ , reverse list -- produce new list */
1160 pko
v2reverse(pko a
, _kt_tag t_enum
)
1164 for (; is_type (a
, t_enum
); a
= unsafe_v2cdr (a
))
1166 p
= v2cons (t_enum
, unsafe_v2car (a
), p
);
1171 /*_ , reverse list -- in-place (Not typechecked) */
1172 /* last_cdr will be the tail of the resulting list. It is usually
1175 list is the list to be reversed. Caller guarantees that list is a
1176 proper list, each link being either some type of vec2 or K_NIL.
1179 unsafe_v2reverse_in_place (pko last_cdr
, pko list
)
1181 pko p
= list
, result
= last_cdr
;
1184 pko scratch
= unsafe_v2cdr (p
);
1185 unsafe_v2set_cdr (p
, result
);
1191 /*_ , append list -- produce new list */
1192 pko
v2append(sc_or_null err_reporter
, pko a
, pko b
, _kt_tag t_enum
)
1199 a
= v2reverse (a
, t_enum
);
1200 /* Correct even if b is nil or a non-list. */
1201 return unsafe_v2reverse_in_place(b
, a
);
1206 /*_ , basvectors (Low vectors) */
1208 /* Above so it can be visible to early typecheck declarations. */
1209 /*_ . Type assert */
1210 void assert_T_is_basvector(_kt_tag t_enum
)
1212 t_enum
&= T_MASKTYPE
;
1214 t_enum
== T_VECTOR
||
1215 t_enum
== T_TYPECHECK
||
1216 t_enum
== T_DESTRUCTURE
1221 /*_ , rough_basvec_init */
1222 /* Create the elements but don't assign to them. */
1224 basvec_init_rough (kt_vector
* pvec
, int len
)
1227 pvec
->els
= (pko
*)GC_MALLOC ((sizeof (pko
) * len
));
1229 /*_ , basvec_init_by_list */
1230 /* Initialize the elements of PVEC with the first LEN elements of
1231 ARGS. ARGS must be a list with at least LEN elements. */
1233 basvec_init_by_list (kt_vector
* pvec
, pko args
)
1237 const int num
= pvec
->len
;
1239 for (x
= args
, i
= 0; i
< num
; x
= cdr (x
), i
++)
1241 assert (is_pair (x
));
1242 pvec
->els
[i
] = car (x
);
1245 /*_ , basvec_init_by_array */
1246 /* Initialize the elements of PVEC with the first LEN elements of
1247 ARRAY. ARRAY must be an array with at least LEN elements. */
1249 basvec_init_by_array (kt_vector
* pvec
, pko
* array
)
1252 const int num
= pvec
->len
;
1253 for (i
= 0; i
< num
; i
++)
1255 pvec
->els
[i
] = array
[i
];
1258 /*_ , basvec_init_by_single */
1260 basvec_init_by_single (kt_vector
* pvec
, pko obj
)
1263 const int num
= pvec
->len
;
1265 for (i
= 0; i
< num
; i
++)
1266 { pvec
->els
[i
] = obj
; }
1269 /*_ , Get element */
1271 basvec_get_element (kt_vector
* pvec
, int index
)
1274 assert(index
< pvec
->len
);
1275 return pvec
->els
[index
];
1279 basvec_fill_array(kt_vector
* pvec
, int max_len
, pko
* array
)
1282 const int num
= pvec
->len
;
1284 assert (num
<= max_len
);
1285 for (i
= 0; i
< num
; i
++)
1287 array
[i
] = pvec
->els
[i
];
1293 basvec_set_element (kt_vector
* pvec
, int index
, pko obj
)
1296 assert(index
< pvec
->len
);
1297 pvec
->els
[index
] = obj
;
1300 /*_ . Treat as boxed */
1301 /* Functions following here assume that kt_vector is in a box by itself. */
1302 /*_ , alloc_basvector */
1304 alloc_basvector (int len
, _kt_tag t_enum
)
1306 assert_T_is_basvector(t_enum
);
1307 ALLOC_BOX_PRESUME(kt_vector
, t_enum
);
1308 basvec_init_rough(&pbox
->data
, len
);
1309 return PTR2PKO(pbox
);
1311 /*_ , mk_basvector_w_args */
1313 mk_basvector_w_args(klink
* sc
, pko args
, _kt_tag t_enum
)
1315 assert_T_is_basvector(t_enum
);
1317 get_list_metrics_aux(args
, metrics
);
1318 if (metrics
[lm_num_nils
] != 1)
1320 KERNEL_ERROR_1 (sc
, "mk_basvector_w_args: not a proper list:", args
);
1322 int len
= metrics
[lm_acyc_len
];
1323 pko vec
= alloc_basvector(len
, t_enum
);
1324 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1325 basvec_init_by_list (pdata
, args
);
1328 /*_ , mk_filled_basvector */
1330 mk_filled_basvector(int len
, pko fill
, _kt_tag t_enum
)
1332 assert_T_is_basvector(t_enum
);
1333 pko vec
= alloc_basvector(len
, t_enum
);
1334 unsafe_basvector_fill (vec
, fill
);
1337 /*_ , mk_basvector_from_array */
1339 mk_basvector_from_array(int len
, pko
* array
, _kt_tag t_enum
)
1341 assert_T_is_basvector(t_enum
);
1342 pko vec
= alloc_basvector(len
, t_enum
);
1343 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1344 basvec_init_by_array (pdata
, array
);
1347 /*_ , mk_foresliced_basvector */
1349 mk_foresliced_basvector (pko vec
, int excess
, _kt_tag t_enum
)
1351 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1352 const int len
= pdata
->len
;
1353 assert (len
>= excess
);
1354 const int remnant_len
= len
- excess
;
1355 return mk_basvector_from_array (remnant_len
,
1356 pdata
->els
+ excess
,
1359 /*_ . Unsafe operations (Typechecks can be disabled) */
1360 /*_ , unsafe_basvector_fill */
1362 unsafe_basvector_fill (pko vec
, pko obj
)
1364 assert_T_is_basvector(_get_type(vec
));
1365 assert_mutable(0,vec
);
1366 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1367 basvec_init_by_single (pdata
, obj
);
1369 /*_ , basvector_len */
1371 basvector_len (pko vec
)
1373 assert_T_is_basvector(_get_type(vec
));
1374 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1378 /*_ , basvector_elem */
1380 basvector_elem (pko vec
, int ielem
)
1382 assert_T_is_basvector(_get_type(vec
));
1383 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1384 return basvec_get_element (pdata
, ielem
);
1387 /*_ , basvector_set_elem */
1389 basvector_set_elem (pko vec
, int ielem
, pko a
)
1391 assert_T_is_basvector(_get_type(vec
));
1392 assert_mutable(0,vec
);
1393 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1394 basvec_set_element (pdata
, ielem
, a
);
1397 /*_ , basvector_fill_array */
1399 basvector_fill_array(pko vec
, int max_len
, pko
* array
)
1401 assert_T_is_basvector(_get_type(vec
));
1402 WITH_UNBOXED_UNSAFE (p_vec
, kt_vector
, vec
);
1403 basvec_fill_array (p_vec
, max_len
, array
);
1406 /*_ . Checked operations */
1407 /*_ , Basic strings (Low strings) */
1408 /*_ . Struct kt_string */
1418 bastring_value (sc_or_null sc
, _kt_tag t_enum
, pko p
)
1420 WITH_PSYC_UNBOXED(kt_string
,p
, t_enum
, sc
);
1421 return pdata
->_svalue
;
1425 bastring_len (sc_or_null sc
, _kt_tag t_enum
, pko p
)
1427 WITH_PSYC_UNBOXED(kt_string
,p
, t_enum
, sc
);
1428 return pdata
->_length
;
1434 store_string (int len_str
, const char *str
, char fill
)
1438 q
= (char *) GC_MALLOC_ATOMIC (len_str
+ 1);
1441 snprintf (q
, len_str
+ 1, "%s", str
);
1445 memset (q
, fill
, len_str
);
1452 mk_bastring (_kt_tag t_enum
, const char *str
, int len
, char fill
)
1454 ALLOC_BOX_PRESUME (kt_string
, t_enum
);
1455 pbox
->data
._svalue
= store_string(len
, str
, fill
);
1456 pbox
->data
._length
= len
;
1457 return PTR2PKO(pbox
);
1460 /*_ . Type assert */
1461 void assert_T_is_bastring(_kt_tag t_enum
)
1463 t_enum
&= T_MASKTYPE
;
1465 t_enum
== T_STRING
||
1466 t_enum
== T_SYMBOL
);
1469 /*_ . Individual object types */
1475 DEF_SIMPLE_PRED(is_bool
,T_NO_K
,ground
, "boolean?/o1")
1478 return (p
== K_T
) || (p
== K_F
);
1481 SIG_CHKARRAY(not) = { REF_OPER(is_bool
), };
1482 DEF_SIMPLE_APPLICATIVE(p00a1
,not,T_NO_K
,ground
, "not?")
1485 if(p
== K_T
) { return K_F
; }
1486 if(p
== K_F
) { return K_T
; }
1487 errx(6, "not: Argument must be boolean");
1491 /*_ . Number constants */
1493 /* We would use these for "folding" operations like cumulative addition. */
1494 static num num_zero
= { 1, {0}, };
1495 static num num_one
= { 1, {1}, };
1498 #define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
1499 #define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
1501 /*_ . Making them */
1504 mk_integer (long num
)
1506 ALLOC_BOX_PRESUME (struct num
, T_NUMBER
);
1507 pbox
->data
.value
.ivalue
= num
;
1508 pbox
->data
.is_fixnum
= 1;
1509 return PTR2PKO(pbox
);
1515 ALLOC_BOX_PRESUME (num
, T_NUMBER
);
1516 pbox
->data
.value
.rvalue
= n
;
1517 pbox
->data
.is_fixnum
= 0;
1518 return PTR2PKO(pbox
);
1526 return mk_integer (n
.value
.ivalue
);
1530 return mk_real (n
.value
.rvalue
);
1534 /*_ . Checking them */
1535 static int is_zero_double (double x
);
1538 num_is_integer (pko p
)
1540 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1541 return (pdata
->is_fixnum
);
1544 DEF_T_PRED (is_number
,T_NUMBER
,ground
,"number?/o1");
1546 DEF_SIMPLE_PRED (is_posint
,T_NO_K
,ground
,"posint?/o1")
1549 return is_integer (p
) && ivalue (p
) >= 0;
1552 /* $$IMPROVE ME later Integer and real should be separate T_ types. */
1553 DEF_SIMPLE_PRED (is_integer
,T_NO_K
,ground
, "integer?/o1")
1556 if(!is_number (p
)) { return 0; }
1557 WITH_UNBOXED_UNSAFE(pdata
,num
,p
);
1558 return (pdata
->is_fixnum
);
1561 DEF_SIMPLE_PRED (is_real
,T_NO_K
,ground
, "real?/o1")
1564 if(!is_number (p
)) { return 0; }
1565 WITH_UNBOXED_UNSAFE(pdata
,num
,p
);
1566 return (!pdata
->is_fixnum
);
1568 DEF_SIMPLE_PRED (is_zero
,T_NO_K
,ground
, "zero?/o1")
1571 /* Behavior on non-numbers wasn't specified so I'm assuming the
1572 predicate just fails. */
1573 if(!is_number (p
)) { return 0; }
1574 WITH_UNBOXED_UNSAFE(pdata
,num
,p
);
1575 if(pdata
->is_fixnum
)
1577 return (ivalue (p
) == 0);
1581 return is_zero_double(rvalue(p
));
1584 /* $$WRITE ME positive? negative? odd? even? */
1585 /*_ . Getting their values */
1589 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1596 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1597 return (num_is_integer (p
) ? pdata
->value
.ivalue
: (long) pdata
->
1604 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1605 return (!num_is_integer (p
)
1606 ? pdata
->value
.rvalue
: (double) pdata
->value
.ivalue
);
1610 set_ivalue (pko p
, long i
)
1612 assert_mutable(0,p
);
1613 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1614 assert (num_is_integer (p
));
1615 pdata
->value
.ivalue
= i
;
1620 add_to_ivalue (pko p
, long i
)
1622 assert_mutable(0,p
);
1623 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1624 assert (num_is_integer (p
));
1625 pdata
->value
.ivalue
+= i
;
1629 /*_ . Operating on numbers */
1631 num_add (num a
, num b
)
1634 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1637 ret
.value
.ivalue
= a
.value
.ivalue
+ b
.value
.ivalue
;
1641 ret
.value
.rvalue
= num_rvalue (a
) + num_rvalue (b
);
1647 num_mul (num a
, num b
)
1650 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1653 ret
.value
.ivalue
= a
.value
.ivalue
* b
.value
.ivalue
;
1657 ret
.value
.rvalue
= num_rvalue (a
) * num_rvalue (b
);
1663 num_div (num a
, num b
)
1666 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
1667 && a
.value
.ivalue
% b
.value
.ivalue
== 0;
1670 ret
.value
.ivalue
= a
.value
.ivalue
/ b
.value
.ivalue
;
1674 ret
.value
.rvalue
= num_rvalue (a
) / num_rvalue (b
);
1680 num_intdiv (num a
, num b
)
1683 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1686 ret
.value
.ivalue
= a
.value
.ivalue
/ b
.value
.ivalue
;
1690 ret
.value
.rvalue
= num_rvalue (a
) / num_rvalue (b
);
1696 num_sub (num a
, num b
)
1699 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1702 ret
.value
.ivalue
= a
.value
.ivalue
- b
.value
.ivalue
;
1706 ret
.value
.rvalue
= num_rvalue (a
) - num_rvalue (b
);
1712 num_rem (num a
, num b
)
1716 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1717 e1
= num_ivalue (a
);
1718 e2
= num_ivalue (b
);
1720 /* modulo should have same sign as second operand */
1735 ret
.value
.ivalue
= res
;
1740 num_mod (num a
, num b
)
1744 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1745 e1
= num_ivalue (a
);
1746 e2
= num_ivalue (b
);
1749 { /* modulo should have same sign as second operand */
1760 ret
.value
.ivalue
= res
;
1765 num_eq (num a
, num b
)
1768 int is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1771 ret
= a
.value
.ivalue
== b
.value
.ivalue
;
1775 ret
= num_rvalue (a
) == num_rvalue (b
);
1782 num_gt (num a
, num b
)
1785 int is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1788 ret
= a
.value
.ivalue
> b
.value
.ivalue
;
1792 ret
= num_rvalue (a
) > num_rvalue (b
);
1798 num_ge (num a
, num b
)
1800 return !num_lt (a
, b
);
1804 num_lt (num a
, num b
)
1807 int is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1810 ret
= a
.value
.ivalue
< b
.value
.ivalue
;
1814 ret
= num_rvalue (a
) < num_rvalue (b
);
1820 num_le (num a
, num b
)
1822 return !num_gt (a
, b
);
1826 /* Round to nearest. Round to even if midway */
1828 round_per_R5RS (double x
)
1830 double fl
= floor (x
);
1831 double ce
= ceil (x
);
1832 double dfl
= x
- fl
;
1833 double dce
= ce
- x
;
1844 if (fmod (fl
, 2.0) == 0.0)
1845 { /* I imagine this holds */
1857 is_zero_double (double x
)
1859 return x
< DBL_MIN
&& x
> -DBL_MIN
;
1863 binary_decode (const char *s
)
1867 while (*s
!= 0 && (*s
== '1' || *s
== '0'))
1877 /* "Psychically" defines a and b. */
1878 #define WITH_PSYC_AB_ARGS(A_TYPE,B_TYPE) \
1879 WITH_UNBOXED_UNSAFE(a,A_TYPE,arg1); \
1880 WITH_UNBOXED_UNSAFE(b,B_TYPE,arg2)
1884 /*_ . Binary operations */
1885 SIG_CHKARRAY(num_binop
) = { REF_OPER(is_number
), REF_OPER(is_number
), };
1886 DEF_SIMPLE_DESTR(num_binop
);
1888 DEF_APPLICATIVE_W_DESTR(ps0a2
,k_add
,REF_DESTR(num_binop
),0,ground
, "add")
1890 WITH_PSYC_AB_ARGS(num
,num
);
1891 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1892 *pdata
= num_add (*a
, *b
);
1893 return PTR2PKO(pbox
);
1896 DEF_APPLICATIVE_W_DESTR(ps0a2
,k_sub
,REF_DESTR(num_binop
),0,ground
, "sub")
1898 WITH_PSYC_AB_ARGS(num
,num
);
1899 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1900 *pdata
= num_sub (*a
, *b
);
1901 return PTR2PKO(pbox
);
1904 DEF_APPLICATIVE_W_DESTR(ps0a2
,k_mul
,REF_DESTR(num_binop
),0,ground
, "mul")
1906 WITH_PSYC_AB_ARGS(num
,num
);
1907 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1908 *pdata
= num_mul (*a
, *b
);
1909 return PTR2PKO(pbox
);
1912 DEF_APPLICATIVE_W_DESTR(ps0a2
,k_div
,REF_DESTR(num_binop
),0,ground
, "div")
1914 WITH_PSYC_AB_ARGS(num
,num
);
1915 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1916 *pdata
= num_div (*a
, *b
);
1917 return PTR2PKO(pbox
);
1920 DEF_APPLICATIVE_W_DESTR(ps0a2
,k_mod
,REF_DESTR(num_binop
),0,ground
, "mod")
1922 WITH_PSYC_AB_ARGS(num
,num
);
1923 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1924 *pdata
= num_mod (*a
, *b
);
1925 return PTR2PKO(pbox
);
1927 /*_ . Binary predicates */
1928 DEF_APPLICATIVE_W_DESTR(bs0a2
,k_gt
,REF_DESTR(num_binop
),0,ground
, ">?/2")
1930 WITH_PSYC_AB_ARGS(num
,num
);
1931 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1932 return num_gt (*a
, *b
);
1935 DEF_APPLICATIVE_W_DESTR(bs0a2
,k_eq
,REF_DESTR(num_binop
),0,simple
, "equal?/2-num-num")
1937 WITH_PSYC_AB_ARGS(num
,num
);
1938 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1939 return num_eq (*a
, *b
);
1944 DEF_T_PRED (is_character
,T_CHARACTER
,ground
, "character?/o1");
1949 WITH_PSYC_UNBOXED(long,p
,T_CHARACTER
,0);
1954 mk_character (int c
)
1956 ALLOC_BOX_PRESUME (long, T_CHARACTER
);
1958 return PTR2PKO(pbox
);
1961 /*_ . Classifying characters */
1962 #if USE_CHAR_CLASSIFIERS
1966 return isascii (c
) && isalpha (c
);
1972 return isascii (c
) && isdigit (c
);
1978 return isascii (c
) && isspace (c
);
1984 return isascii (c
) && isupper (c
);
1990 return isascii (c
) && islower (c
);
1993 /*_ . Character names */
1995 static const char *charnames
[32] = {
2031 is_ascii_name (const char *name
, int *pc
)
2034 for (i
= 0; i
< 32; i
++)
2036 if (stricmp (name
, charnames
[i
]) == 0)
2042 if (stricmp (name
, "del") == 0)
2052 /*_ , Void objects */
2054 DEF_T_PRED (is_key
, T_KEY
,no
,"");
2058 BOX_OF_VOID (K_NIL
);
2059 BOX_OF_VOID (K_EOF
);
2060 BOX_OF_VOID (K_INERT
);
2061 BOX_OF_VOID (K_IGNORE
);
2062 /*_ . "Secret" objects for built-in keyed dynamic bindings */
2063 BOX_OF_VOID (K_PRINT_FLAG
);
2064 BOX_OF_VOID (K_TRACING
);
2065 BOX_OF_VOID (K_INPORT
);
2066 BOX_OF_VOID (K_OUTPORT
);
2067 BOX_OF_VOID (K_NEST_DEPTH
);
2068 /*_ . Keys for typecheck */
2069 BOX_OF_VOID (K_TYCH_DOT
);
2070 BOX_OF_VOID (K_TYCH_REPEAT
);
2071 BOX_OF_VOID (K_TYCH_OPTIONAL
);
2072 BOX_OF_VOID (K_TYCH_IMP_REPEAT
);
2073 BOX_OF_VOID (K_TYCH_NO_TYPE
);
2075 /*_ . Making them dynamically */
2076 DEF_CFUNC(p00a0
, mk_void
, K_NO_TYPE
,T_NO_K
)
2078 ALLOC_BOX(pbox
,T_KEY
,kt_boxed_void
);
2079 return PTR2PKO(pbox
);
2082 DEF_SIMPLE_PRED(is_null
,T_NO_K
,ground
, "null?/o1")
2087 DEF_SIMPLE_PRED(is_inert
,T_NO_K
,ground
, "inert?/o1")
2090 return p
== K_INERT
;
2092 DEF_SIMPLE_PRED(is_ignore
,T_NO_K
,ground
, "ignore?/o1")
2095 return p
== K_IGNORE
;
2099 /*_ , Typecheck & destructure objects */
2101 /* _car is vector component, _cdr is list component. */
2102 typedef kt_vec2 kt_destr_result
;
2103 /*_ . Enumeration */
2111 DEF_T_PRED (is_destr_result
, T_DESTR_RESULT
, no
, "");
2112 /*_ . Building them */
2113 /*_ , can_be_trivpred */
2114 /* Return true if the object can be used as a trivial predicate: An
2115 xary operative that does not call Kernel and returns a boolean as
2117 DEF_SIMPLE_PRED(can_be_trivpred
,T_NO_K
,unsafe
,"trivpred?/o1")
2120 if(!no_call_k(p
)) { return 0; }
2121 switch(_get_type(p
))
2125 WITH_UNBOXED_UNSAFE(pdata
,kt_cfunc
,p
);
2128 case klink_ftype_b00a1
:
2150 /*_ , k_to_trivpred */
2151 /* Convert a unary or nary function to xary. If not possible, return
2153 /* $$OBSOLESCENT Only used in print lookup, which will change */
2155 k_to_trivpred(pko p
)
2157 if(is_applicative(p
))
2158 { p
= unwrap_all(p
); }
2160 if(can_be_trivpred(p
))
2165 /*_ , type-keys environment */
2166 RGSTR(type
-keys
, "cyclic-repeat", REF_KEY(K_TYCH_IMP_REPEAT
) )
2167 RGSTR(type
-keys
, "optional", REF_KEY(K_TYCH_OPTIONAL
) )
2168 RGSTR(type
-keys
, "repeat", REF_KEY(K_TYCH_REPEAT
) )
2169 RGSTR(type
-keys
, "dot", REF_KEY(K_TYCH_DOT
) )
2171 int any_k (kt_vector
* p_vec_guts
)
2174 for (i
= 0; i
< p_vec_guts
->len
; i
++)
2176 pko obj
= p_vec_guts
->els
[i
];
2177 WITH_BOX_TYPE(tag
,obj
);
2178 if (*tag
| ~(T_NO_K
)) { return 1; }
2184 DEF_APPLICATIVE_W_DESTR (ps0a1
, mk_typecheck
, REF_OPER(is_finite_list
),T_NO_K
,unsafe
, "listtype/N-trivpred")
2186 pko vec
= mk_basvector_w_args(sc
, arg1
, T_TYPECHECK
| T_IMMUTABLE
| T_NO_K
);
2187 #if 0 /* $$ENABLE ME later */
2188 /* If everything is T_NO_K, then give flag T_NO_K. */
2189 WITH_UNBOXED_UNSAFE (pdata
, kt_vector
, vec
);
2192 WITH_BOX_TYPE(tag
,vec
);
2198 /*_ , Destructurer */
2199 DEF_APPLICATIVE_W_DESTR (ps0a1
, mk_destructurer
, REF_OPER(is_finite_list
),T_NO_K
,unsafe
, "destructure-list/N-trivpred")
2201 /* $$IMPROVE MY SUPPORT A destructurer should fill up this */
2203 get_list_metrics_aux(arg1
, metrics
);
2204 if (metrics
[lm_num_nils
] != 1)
2206 KERNEL_ERROR_1 (sc
, "mk_destructurer: not a proper list:", arg1
);
2208 int len
= metrics
[lm_acyc_len
];
2209 ALLOC_BOX_PRESUME(kt_destr_list
, T_DESTRUCTURE
| T_IMMUTABLE
| T_NO_K
);
2210 basvec_init_rough (&pdata
->cvec
, len
);
2211 basvec_init_by_list (&pdata
->cvec
, arg1
);
2212 pdata
->num_targets
= -1;
2214 #if 0 /* $$ENABLE ME later when typemiss check is OK for this */
2215 /* If everything is T_NO_K, then give flag T_NO_K. */
2216 if (!any_k (&pdata
->cvec
))
2218 WITH_BOX_TYPE(tag
,vec
);
2222 return PTR2PKO(pbox
);
2224 /*_ , Destructurer Result state */
2225 /* Really a mixed vector/list */
2226 /*_ . mk_destr_result */
2229 (int len
, pko
* array
, pko more_vals
)
2231 pko vec
= mk_basvector_from_array(len
, array
, T_VECTOR
);
2232 return v2cons (T_DESTR_RESULT
, vec
, more_vals
);
2234 /*_ . mk_destr_result_add */
2237 (pko old
, int len
, pko
* array
)
2239 pko val_list
= unsafe_v2cdr (old
);
2241 for (i
= 0; i
< len
; i
++)
2243 val_list
= cons ( array
[i
], val_list
);
2245 return v2cons (T_DESTR_RESULT
,
2249 /*_ . destr_result_fill_array */
2251 destr_result_fill_array (pko dr
, int max_len
, pko
* array
)
2253 /* Assume errors are due to C code. */
2255 WITH_PSYC_UNBOXED (kt_destr_result
, dr
, T_DESTR_RESULT
, 0)
2257 basvector_len (pdata
->_car
);
2258 basvector_fill_array(pdata
->_car
, vec_len
, array
);
2259 /* We get args earliest lowest, so insert them in reverse order. */
2260 int list_len
= list_length (pdata
->_cdr
);
2261 int i
= vec_len
+ list_len
- 1;
2262 assert (i
< max_len
);
2264 for (args
= pdata
->_cdr
; args
!= K_NIL
; args
= cdr (args
), i
--)
2266 array
[i
] = car (args
);
2270 /*_ , destr_result_to_vec */
2271 SIG_CHKARRAY (destr_result_to_vec
) =
2273 REF_OPER (is_destr_result
),
2276 DEF_SIMPLE_CFUNC (p00a1
, destr_result_to_vec
, T_NO_K
)
2278 WITH_1_ARGS (destr_result
);
2279 WITH_UNBOXED_UNSAFE (p_destr_result
, kt_destr_result
, destr_result
);
2281 basvector_len (p_destr_result
->_car
) +
2282 list_length (p_destr_result
->_cdr
);
2283 pko vec
= mk_vector (len
, K_NIL
);
2284 WITH_UNBOXED_UNSAFE (p_vec
, kt_destr_list
, vec
);
2285 destr_result_fill_array (destr_result
, len
, p_vec
->cvec
.els
);
2289 /*_ . Particular typechecks */
2290 /*_ , Any singleton */
2291 pko _K_ARRAY_any_singleton
[] = { K_ANY
, };
2292 DEF_DESTR(_K_any_singleton
,_K_ARRAY_any_singleton
);
2293 /*_ , Typespec itself */
2294 #define K_TY_TYPESPEC K_ANY
2295 /*_ , Destructure spec itself */
2296 #define K_TY_DESTRSPEC K_ANY
2297 /*_ , Top type (Always succeeds) */
2298 RGSTR(ground
, "true/o1", REF_OPER(is_any
))
2299 DEF_CFUNC(b00a1
,is_any
,K_ANY_SINGLETON
,T_NO_K
)
2302 /* Not entirely redundant; Used internally to check scheduled returns. */
2303 DEF_CFUNC(b00a1
,is_true
,K_ANY_SINGLETON
,T_NO_K
)
2309 /*_ . Internal signatures */
2312 (klink
*sc
, pko argobject
, pko
* ar_typespec
, int count
, int style
);
2314 where_typemiss_repeat
2315 (klink
*sc
, pko argobject
, pko
* ar_typespec
, int count
, int style
);
2317 static where_typemiss_do_spec
2318 (klink
* sc
, pko argobject
, pko
* ar_typespec
, int left
);
2320 typecheck_by_vec (klink
* sc
, pko argobject
, pko
* ar_typespec
, int left
);
2322 /*_ . Typecheck operations */
2324 call_T_typecheck(pko T
, pko obj
)
2326 WITH_PSYC_UNBOXED(typep_t
,T
,T_TYPEP
,0);
2327 return is_type(obj
,pdata
->T_tag
);
2330 /* This is an optimization under-the-hood for running
2331 possibly-compound predicates. Ultimately it will not be exposed.
2332 Later it may have a Kernel "safe counterpart" that is optimized to
2335 It should not call anything that calls Kernel. All its
2336 "components" should be trivpreds (xary operatives that don't use
2337 eval loop), satisfying can_be_trivpred, generally specified
2339 /* We don't have a typecheck typecheck predicate yet, so accept
2340 anything for arg2. */
2341 SIG_CHKARRAY(typecheck
) = { K_ANY
, K_ANY
, };
2342 DEF_SIMPLE_APPLICATIVE (bs0a2
, typecheck
,T_NO_K
,unsafe
,"type?")
2344 WITH_2_ARGS(argobject
,typespec
);
2345 assert(no_call_k(typespec
));
2346 switch(_get_type(typespec
))
2350 WITH_UNBOXED_UNSAFE(pdata
,kt_cfunc
,typespec
);
2353 case klink_ftype_b00a1
:
2355 return pdata
->func
.f_b00a1(argobject
);
2358 errx(7, "typecheck: Object is not a typespec");
2361 break; /* NOTREACHED */
2363 return call_T_typecheck(typespec
, argobject
);
2364 case T_DESTRUCTURE
: /* Fallthru */
2366 WITH_UNBOXED_UNSAFE(pdata
,kt_destr_list
,typespec
);
2367 pko
* ar_typespec
= pdata
->cvec
.els
;
2368 int left
= pdata
->cvec
.len
;
2369 return typecheck_by_vec (sc
, argobject
, ar_typespec
, left
);
2373 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,typespec
);
2374 pko
* ar_typespec
= pdata
->els
;
2375 int left
= pdata
->len
;
2376 return typecheck_by_vec (sc
, argobject
, ar_typespec
, left
);
2380 errx(7, "typecheck: Object is not a typespec");
2382 return 0; /* NOTREACHED */
2384 /*_ , typecheck_by_vec */
2386 typecheck_by_vec (klink
* sc
, pko argobject
, pko
* ar_typespec
, int left
)
2388 int saw_optional
= 0;
2389 for( ; left
; ar_typespec
++, left
--)
2391 pko tych
= *ar_typespec
;
2392 /**** Check for special keys ****/
2393 if(tych
== REF_KEY(K_TYCH_DOT
))
2397 KERNEL_ERROR_0 (sc
, "typecheck: After dot there must "
2398 "be exactly one typespec");
2401 { return typecheck(sc
, argobject
, ar_typespec
[1]); }
2403 if(tych
== REF_KEY(K_TYCH_OPTIONAL
))
2407 KERNEL_ERROR_0 (sc
, "typecheck: Can't have two optionals");
2415 if(tych
== REF_KEY(K_TYCH_REPEAT
))
2418 typecheck_repeat(sc
,argobject
,
2423 if(tych
== REF_KEY(K_TYCH_IMP_REPEAT
))
2426 typecheck_repeat(sc
,argobject
,
2432 /*** Manage stepping ***/
2433 if(!is_pair(argobject
))
2443 pko c
= pair_car(0,argobject
);
2444 argobject
= pair_cdr(0,argobject
);
2446 /*** Do the check ***/
2447 if (!typecheck(sc
, c
, tych
)) { return 0; }
2450 if(argobject
!= K_NIL
)
2455 /*_ , typecheck_repeat */
2458 (klink
*sc
, pko argobject
, pko
* ar_typespec
, int count
, int style
)
2461 get_list_metrics_aux(argobject
, metrics
);
2462 /* Dotted lists don't satisfy repeat */
2463 if(!metrics
[lm_num_nils
]) { return 0; }
2464 if(metrics
[lm_cyc_len
])
2466 /* STYLE may not allow cycles. */
2469 /* If there's a cycle and count doesn't fit into it exactly,
2470 call that a mismatch. */
2471 if(count
% metrics
[lm_cyc_len
])
2474 /* Check the car of each pair. */
2477 for(step
= 0, i
= 0;
2478 step
< metrics
[lm_num_pairs
];
2479 ++step
, ++i
, argobject
= pair_cdr(0,argobject
))
2481 if(i
== count
) { i
= 0; }
2482 assert(is_pair(argobject
));
2483 pko tych
= ar_typespec
[i
];
2484 pko c
= pair_car(0,argobject
);
2485 if (!typecheck(sc
, c
, tych
)) { return 0; }
2489 /*_ , where_typemiss */
2490 /* This parallels typecheck, but where typecheck returned a boolean,
2491 this returns an object indicating where the type failed to match. */
2492 SIG_CHKARRAY(where_typemiss
) = { K_ANY
, K_ANY
, };
2493 DEF_SIMPLE_APPLICATIVE (ps0a2
, where_typemiss
,T_NO_K
,unsafe
, "where-typemiss")
2495 /* Return a list indicating how TYPESPEC failed to match
2497 WITH_2_ARGS(argobject
,typespec
);
2498 assert(no_call_k(typespec
));
2499 switch(_get_type(typespec
))
2503 WITH_UNBOXED_UNSAFE(pdata
,kt_cfunc
,typespec
);
2506 case klink_ftype_b00a1
:
2508 if (pdata
->func
.f_b00a1(argobject
))
2513 { return LIST1(typespec
); }
2516 errx(7, "where_typemiss: Object is not a typespec");
2520 break; /* NOTREACHED */
2523 WITH_PSYC_UNBOXED(typep_t
,typespec
,T_TYPEP
,0);
2524 if (call_T_typecheck(typespec
, argobject
))
2527 { return LIST1(mk_string(type_err_string(pdata
->T_tag
))); }
2532 WITH_UNBOXED_UNSAFE(pdata
,kt_destr_list
,typespec
);
2533 return where_typemiss_do_spec(sc
, argobject
, pdata
->cvec
.els
, pdata
->cvec
.len
);
2537 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,typespec
);
2538 return where_typemiss_do_spec(sc
, argobject
, pdata
->els
, pdata
->len
);
2542 errx(7,"where_typemiss: Object is not a typespec");
2545 return 0; /* NOTREACHED */
2547 /*_ , where_typemiss_do_spec */
2549 where_typemiss_do_spec
2550 (klink
* sc
, pko argobject
, pko
* ar_typespec
, int left
)
2552 int saw_optional
= 0;
2554 for( ; left
; ar_typespec
++, left
--)
2556 pko tych
= *ar_typespec
;
2557 /**** Check for special keys ****/
2558 if(tych
== REF_KEY(K_TYCH_DOT
))
2562 KERNEL_ERROR_0 (sc
, "where_typemiss: After dot there must "
2563 "be exactly one typespec");
2568 where_typemiss(sc
, argobject
, ar_typespec
[1]);
2572 LISTSTAR3(mk_integer(el_num
),
2580 if(tych
== REF_KEY(K_TYCH_OPTIONAL
))
2584 KERNEL_ERROR_0 (sc
, "where_typemiss: Can't have two optionals");
2592 if(tych
== REF_KEY(K_TYCH_REPEAT
))
2595 where_typemiss_repeat(sc
,argobject
,
2600 { return LISTSTAR3(mk_integer(el_num
),mk_symbol("repeat"), result
); }
2604 if(tych
== REF_KEY(K_TYCH_IMP_REPEAT
))
2607 where_typemiss_repeat(sc
,argobject
,
2612 { return LISTSTAR3(mk_integer(el_num
),mk_symbol("improper-repeat"),result
); }
2617 /*** Manage stepping ***/
2618 if(!is_pair(argobject
))
2622 return LIST2(mk_integer(el_num
), mk_symbol("too-few"));
2630 pko c
= pair_car(0,argobject
);
2631 argobject
= pair_cdr(0,argobject
);
2634 /*** Do the check ***/
2635 pko result
= where_typemiss(sc
, c
, tych
);
2637 { return LISTSTAR2(mk_integer(el_num
),result
); }
2640 if(argobject
!= K_NIL
)
2641 { return LIST2(mk_integer(el_num
), mk_symbol("too-many")); }
2645 /*_ , where_typemiss_repeat */
2647 where_typemiss_repeat
2648 (klink
*sc
, pko argobject
, pko
* ar_typespec
, int count
, int style
)
2651 get_list_metrics_aux(argobject
, metrics
);
2652 /* Dotted lists don't satisfy repeat */
2653 if(!metrics
[lm_num_nils
]) { return LIST1(mk_symbol("dotted")); }
2654 if(metrics
[lm_cyc_len
])
2656 /* STYLE may not allow cycles. */
2658 { return LIST1(mk_symbol("circular")); }
2659 /* If there's a cycle and count doesn't fit into it exactly,
2660 call that a mismatch. */
2661 if(count
% metrics
[lm_cyc_len
])
2662 { return LIST1(mk_symbol("misaligned-end")); }
2664 /* Check the car of each pair. */
2667 for(step
= 0, i
= 0;
2668 step
< metrics
[lm_num_pairs
];
2669 ++step
, ++i
, argobject
= pair_cdr(0,argobject
))
2671 if(i
== count
) { i
= 0; }
2672 assert(is_pair(argobject
));
2673 pko tych
= ar_typespec
[i
];
2674 pko c
= pair_car(0,argobject
);
2675 pko result
= where_typemiss(sc
, c
, tych
);
2677 { return LISTSTAR2(mk_integer(step
),result
); }
2682 /*_ . Destructuring operations */
2683 /*_ , destructure_by_bool */
2684 /* Just for calling back after a freeform predicate */
2685 SIG_CHKARRAY (destructure_by_bool
) =
2687 REF_OPER (is_destr_result
),
2691 DEF_SIMPLE_CFUNC (ps0a3
, destructure_by_bool
, 0)
2693 WITH_3_ARGS (destr_result
, argobject
, satisfied
);
2694 if (satisfied
== K_T
)
2697 mk_destr_result_add (destr_result
, 1, &argobject
);
2699 else if (satisfied
!= K_F
)
2701 KERNEL_ERROR_0 (sc
, "Predicate should return a boolean");
2705 KERNEL_ERROR_0 (sc
, "type mismatch on non-C predicate");
2709 /*_ , destructure_how_many */
2711 destructure_how_many (pko typespec
)
2713 switch (_get_type(typespec
))
2717 WITH_UNBOXED_UNSAFE(pdata
,kt_destr_list
,typespec
);
2718 if (pdata
->num_targets
>= 0)
2719 { return pdata
->num_targets
;}
2723 pko
* ar_typespec
= pdata
->cvec
.els
;
2724 int left
= pdata
->cvec
.len
;
2725 for( ; left
; ar_typespec
++, left
--)
2727 pko tych
= *ar_typespec
;
2728 count
+= destructure_how_many (tych
);
2730 pdata
->num_targets
= count
;
2740 /*_ , destructure_make_ops */
2742 destructure_make_ops
2743 (pko argobject
, pko typespec
, int saw_optional
)
2746 /* Operations to run, in reverse order. */
2748 /* ^V= result-so-far */
2749 REF_OPER (destructure_resume
),
2750 /* V= (result-so-far argobject spec optional?) */
2751 mk_load (LIST5 (mk_load_ix (1, 0),
2754 kernel_bool (saw_optional
),
2756 mk_store (K_ANY
, 1),
2757 /* V= forced-argobject */
2759 /* ^V= (argobject) */
2760 mk_load (LIST1 (argobject
)),
2762 /* ^V= result-so-far */
2765 /*_ , destructure_make_ops_to_bool */
2767 destructure_make_ops_to_bool
2768 (pko argobject
, pko op_on_argobject
)
2770 assert (is_combiner (op_on_argobject
));
2772 /* Operations to run, in reverse order. */
2774 /* ^V= result-so-far */
2775 REF_OPER (destructure_by_bool
),
2776 /* V= (result-so-far bool spec) */
2777 mk_load (LIST3 (mk_load_ix (1, 0),
2779 mk_load_ix (0, 0))),
2780 mk_store (K_ANY
, 1),
2783 /* ^V= (argobject) */
2784 mk_load (LIST1 (argobject
)),
2786 /* ^V= result-so-far */
2789 /*_ , destructure */
2790 /* Callers: past_end should point into the same array as *outarray.
2791 It will indicate the maximum number number of elements we may
2792 write. The return value is the remainder of the outarray if
2793 successful, otherwise NULL.
2794 The meaning of extra_result depends on the return value:
2795 * On success, it's unused.
2796 * On destr_err, it will hold an error object.
2797 * On destr_must_call_k, it will hold a list of operations.
2801 (klink
* sc
, pko argobject
, pko typespec
, pko
** outarray
,
2802 pko
* past_end
, pko
* extra_result
, int saw_optional
)
2804 if(*outarray
== past_end
)
2806 /* $$IMPROVE ME Treat this error like other mismatches */
2807 KERNEL_ERROR_0 (sc
, "destructure: past end of output array");
2809 if(_get_type(typespec
) == T_DESTRUCTURE
)
2811 WITH_UNBOXED_UNSAFE(pdata
,kt_destr_list
,typespec
);
2812 pko
* ar_typespec
= pdata
->cvec
.els
;
2813 int left
= pdata
->cvec
.len
;
2815 for( ; left
; ar_typespec
++, left
--)
2817 pko tych
= *ar_typespec
;
2819 /**** Check for special keys ****/
2820 if(tych
== REF_KEY(K_TYCH_DOT
))
2824 KERNEL_ERROR_0 (sc
, "destructure: After dot there must "
2825 "be exactly one typespec");
2829 kt_destr_outcome outcome
=
2830 destructure(sc
, argobject
,
2836 /* If there's error, contribute to describing its
2838 if (outcome
== destr_err
)
2841 LISTSTAR3(mk_integer(el_num
),
2848 if(tych
== REF_KEY(K_TYCH_OPTIONAL
))
2852 KERNEL_ERROR_0 (sc
, "destructure: Can't have two optionals");
2860 /*** Manage stepping ***/
2861 if(!is_pair(argobject
))
2865 *outarray
[0] = K_INERT
;
2869 if (is_promise (argobject
))
2871 WITH_BOX_TYPE(tag
,typespec
);
2873 mk_foresliced_basvector (typespec
,
2874 pdata
->cvec
.len
- left
,
2877 destructure_make_ops (argobject
,
2880 return destr_must_call_k
;
2884 /* $$IMPROVE ME These symbols should be made
2886 /* $$IMPROVE ME These location operations should be
2889 LIST2(mk_integer(el_num
), mk_symbol("too-few"));
2895 pko c
= pair_car(0,argobject
);
2896 argobject
= pair_cdr(0,argobject
);
2909 /* Success keeps exploring */
2912 /* Simple error ends exploration */
2913 /* Contribute to describing its location. */
2915 LISTSTAR2(mk_integer(el_num
),*extra_result
);
2917 case destr_must_call_k
:
2918 /* must-call-K schedules to resume in this state,
2921 WITH_BOX_TYPE(tag
,typespec
);
2922 /* $$IMPROVE ME If length = 0, this is just
2923 REF_OPER (is_null) */
2925 mk_foresliced_basvector (typespec
,
2926 pdata
->cvec
.len
- left
+ 1,
2928 pko raw_oplist
= *extra_result
;
2931 REF_OPER (destructure_resume
),
2932 /* ^V= (result-so-far argobject spec
2934 mk_load (LIST5 (mk_load_ix (0, 0),
2937 kernel_bool (saw_optional
),
2939 mk_store (K_ANY
, 1),
2940 /* ^V= result-so-far */
2942 return destr_must_call_k
;
2945 errx (7, "Unrecognized enumeration");
2949 if(argobject
== K_NIL
)
2950 { return destr_success
; }
2951 else if (is_promise (argobject
))
2953 pko new_typespec
= REF_OPER (is_null
);
2955 destructure_make_ops (argobject
,
2958 return destr_must_call_k
;
2963 LIST2(mk_integer(el_num
), mk_symbol("too-many"));
2968 else if (!no_call_k(typespec
))
2970 if (!is_combiner (typespec
))
2972 KERNEL_ERROR_0 (sc
, "spec must be a combiner");
2977 destructure_make_ops_to_bool (argobject
, typespec
);
2978 return destr_must_call_k
;
2980 else if(typecheck(sc
, argobject
, typespec
))
2982 *outarray
[0] = argobject
;
2984 return destr_success
;
2986 else if (is_promise (argobject
))
2989 destructure_make_ops (argobject
,
2992 return destr_must_call_k
;
2996 pko result
= where_typemiss(sc
, argobject
, typespec
);
2997 result
= result
? result
: mk_string("Couldn't find the typemiss");
2998 *extra_result
= result
;
3002 /*_ , destructure_to_array */
3004 destructure_to_array
3006 pko obj
, /* Object to extract values from */
3007 pko type
, /* Type spec */
3008 pko
* array
, /* Array to be filled */
3009 size_t length
, /* Maximum length of that array */
3010 pko resume_op
, /* Combiner to schedule if we resume */
3011 pko resume_data
/* Extra data to the resume op */
3014 if (type
== K_NO_TYPE
)
3016 pko
* orig_array
= array
;
3017 pko extra_result
= 0;
3018 kt_destr_outcome outcome
=
3019 destructure (sc
, obj
, type
, &array
, array
+ length
, &extra_result
, 0);
3027 assert (extra_result
);
3028 /* $$PUNT: For now, use resume_data as marker because it is
3029 often the cfunc being called. */
3030 _klink_error_1 (sc
, "type mismatch:",
3031 LIST2(resume_data
, extra_result
));
3036 case destr_must_call_k
:
3038 /* Arrange for a resume. */
3039 int read_len
= array
- orig_array
;
3040 pko result_so_far
= mk_destr_result (read_len
, orig_array
, K_NIL
);
3041 assert (is_combiner (resume_op
));
3042 CONTIN_0_RAW (resume_op
, sc
);
3043 /* ^^^V= (final-destr_result . resume_data) */
3044 CONTIN_0_RAW (mk_load (LISTSTAR2 (mk_load_ix (0, 0),
3047 CONTIN_0_RAW (mk_store (K_ANY
, 1), sc
);
3048 /* ^^^V= final-destr_result */
3049 schedule_rv_list (sc
, extra_result
);
3050 /* ^^^V= current-destr_result */
3051 /* $$ENCAPSULATE ME */
3052 sc
->value
= result_so_far
;
3053 longjmp (sc
->pseudocontinuation
, 1);
3060 errx (7, "Unrecognized enumeration");
3064 /*_ , destructure_resume */
3065 SIG_CHKARRAY (destructure_resume
) =
3067 REF_OPER (is_destr_result
),
3073 DEF_SIMPLE_CFUNC (ps0a5
, destructure_resume
, 0)
3075 WITH_5_ARGS (destr_result
, argobject
, typespec
, opt_p
, err_val
);
3076 const int max_args
= 5;
3077 pko arg_array
[max_args
];
3078 pko
* outarray
= arg_array
;
3079 pko extra_result
= 0;
3080 kt_destr_outcome outcome
=
3085 arg_array
+ max_args
,
3092 int new_len
= outarray
- arg_array
;
3094 mk_destr_result_add (destr_result
, new_len
, arg_array
);
3098 /* $$PUNT: For now, no marker, just location data. */
3099 KERNEL_ERROR_1 (sc
, "type mismatch:", extra_result
);
3102 case destr_must_call_k
:
3104 /* Arrange for another force+resume. This will feed whatever
3105 was there before. */
3106 int read_len
= outarray
- arg_array
;
3108 mk_destr_result_add (destr_result
,
3111 schedule_rv_list (sc
, extra_result
);
3112 return result_so_far
;
3117 errx (7, "Unrecognized enumeration");
3121 /*_ , do-destructure */
3122 /* We don't have a typecheck typecheck predicate yet, so accept
3123 anything for arg2. Really it can be what typecheck accepts or
3124 T_DESTRUCTURE, checked recursively. */
3125 SIG_CHKARRAY (do_destructure
) = { K_ANY
, K_ANY
, };
3126 DEF_SIMPLE_APPLICATIVE (ps0a2
, do_destructure
,T_NO_K
,unsafe
,"do-destructure")
3128 WITH_2_ARGS (argobject
,typespec
);
3129 int len
= destructure_how_many (typespec
);
3130 pko vec
= mk_vector (len
, K_NIL
);
3131 WITH_UNBOXED_UNSAFE (pdata
,kt_destr_list
,vec
);
3132 destructure_to_array
3138 REF_OPER (destr_result_to_vec
),
3144 /*_ , C functions as objects */
3147 typedef struct kt_opstore
3149 pko destr
; /* Often a T_DESTRUCTURE */
3154 DEF_T_PRED (is_cfunc
, T_CFUNC
,no
,"");
3157 /* For external use, if some code ever wants to make these objects
3159 /* $$MAKE ME SAFE Set type-check fields */
3161 mk_cfunc (const kt_cfunc
* f
)
3163 typedef kt_boxed_cfunc TT
;
3164 errx(4, "Don't use mk_cfunc yet")
3165 TT
*pbox
= GC_MALLOC (sizeof (TT
));
3166 pbox
->type
= T_CFUNC
;
3168 return PTR2PKO(pbox
);
3172 INLINE
const kt_cfunc
*
3173 get_cfunc_func (pko p
)
3175 WITH_PSYC_UNBOXED(kt_cfunc
,p
,T_CFUNC
,0)
3178 /*_ . cfunc_resume */
3180 /*_ . mk_cfunc_resume */
3182 mk_cfunc_resume (pko cfunc
)
3184 ALLOC_BOX_PRESUME (kt_cfunc
, T_CFUNC_RESUME
);
3185 pbox
->data
= *get_cfunc_func (cfunc
);
3186 return PTR2PKO(pbox
);
3189 /*_ . Curried functions */
3190 /*_ , About objects */
3193 { return is_type (p
, T_CURRIED
); }
3196 mk_curried (decurrier_f decurrier
, pko args
, pko next
)
3198 ALLOC_BOX(pbox
,T_CURRIED
,kt_boxed_curried
);
3199 pbox
->data
.decurrier
= decurrier
;
3200 pbox
->data
.args
= args
;
3201 pbox
->data
.next
= next
;
3202 pbox
->data
.argcheck
= 0;
3203 return PTR2PKO(pbox
);
3206 /*_ . call_curried */
3208 call_curried(klink
* sc
, pko curried
, pko value
)
3210 WITH_PSYC_UNBOXED(kt_curried
,curried
,T_CURRIED
,sc
);
3212 /* First schedule the next one if there is any */
3215 klink_push_cont(sc
, pdata
->next
);
3218 /* Then call the decurrier with the data field and the value,
3219 returning its result. */
3220 return pdata
->decurrier (sc
, pdata
->args
, value
);
3225 typedef kt_vector kt_chain
;
3229 #define SIG_CHAIN(C_NAME) pko CHAIN_NAME(C_NAME)[]
3230 #define DEF_CHAIN(NAME, ARRAY_NAME) \
3231 DEF_VEC(T_CHAIN | T_IMMUTABLE, NAME, ARRAY_NAME)
3233 #define DEF_SIMPLE_CHAIN(C_NAME) \
3234 RGSTR(all-builtins,"C-" #C_NAME, REF_OPER (C_NAME)) \
3235 DEF_CHAIN(OPER(C_NAME), CHAIN_NAME(C_NAME))
3240 schedule_chain(klink
* sc
, const kt_vector
* chain
)
3242 _kt_spagstack dump
= sc
->dump
;
3244 for(i
= chain
->len
- 1; i
>= 0; i
--)
3246 pko comb
= chain
->els
[i
];
3247 /* If frame_depth is unassigned, assign it. */
3248 if(_get_type(comb
) == T_STORE
)
3250 WITH_UNBOXED_UNSAFE( pdata
, kt_opstore
, comb
);
3251 if(pdata
->frame_depth
< 0)
3252 { pdata
->frame_depth
= chain
->len
- 1 - i
; }
3254 /* Push it as a combiner */
3255 dump
= klink_push_cont_aux(dump
, comb
, sc
->envir
);
3262 eval_chain( klink
* sc
, pko functor
, pko value
)
3264 WITH_PSYC_UNBOXED( kt_vector
, functor
, T_CHAIN
, 0 );
3265 schedule_chain( sc
, pdata
);
3268 /*_ . schedule_rv_list */
3270 schedule_rv_list (klink
* sc
, pko list
)
3273 _kt_spagstack dump
= sc
->dump
;
3274 for(; list
!= K_NIL
; list
= cdr (list
))
3276 pko comb
= car (list
);
3277 /* $$PUNT If frame_depth is unassigned, assign it. */
3279 /* Push it as a combiner */
3280 dump
= klink_push_cont_aux(dump
, comb
, sc
->envir
);
3287 mk_notrace( pko combiner
)
3289 ALLOC_BOX_PRESUME( pko
, T_NOTRACE
);
3291 return PTR2PKO(pbox
);
3296 notrace_comb( pko p
)
3298 WITH_PSYC_UNBOXED( pko
, p
, T_NOTRACE
, 0 );
3304 #define STORE_DEF(DATA) \
3305 { T_STORE | T_IMMUTABLE, { DATA, -1, }, }
3307 #define ANON_STORE(DATA) \
3308 ANON_REF (kt_opstore, STORE_DEF(DATA))
3310 /*_ . dynamically */
3312 mk_store (pko data
, int depth
)
3314 ALLOC_BOX_PRESUME(kt_opstore
, T_STORE
| T_IMMUTABLE
);
3315 pdata
->destr
= data
;
3316 pdata
->frame_depth
= depth
;
3317 return PTR2PKO(pbox
);
3322 typedef pko kt_opload
;
3326 #define LOAD_DEF( DATA ) \
3327 { T_LOAD | T_IMMUTABLE, DATA, }
3329 #define ANON_LOAD( DATA ) \
3330 ANON_REF( pko, LOAD_DEF( DATA ))
3332 #define ANON_LOAD_IX( X, Y ) \
3333 ANON_PAIR(ANON_REF(num, INT_DEF( X )), \
3334 ANON_REF(num, INT_DEF( Y )))
3335 /*_ . dynamically */
3338 mk_load_ix (int x
, int y
)
3340 return cons (mk_integer (x
), mk_integer (y
));
3346 ALLOC_BOX_PRESUME(kt_opload
, T_LOAD
| T_IMMUTABLE
);
3348 return PTR2PKO(pbox
);
3351 /*_ , pairs proper */
3353 DEF_T_PRED (is_pair
, T_PAIR
,ground
, "pair?/o1");
3356 SIG_CHKARRAY(Xcons
) = { K_ANY
, K_ANY
, };
3357 DEF_SIMPLE_DESTR(Xcons
);
3358 DEF_APPLICATIVE_W_DESTR(p00a2
,mk_pair
, REF_DESTR(Xcons
),T_NO_K
,ground
, "cons")
3364 DEF_APPLICATIVE_W_DESTR(p00a2
,mk_mutable_pair
, REF_DESTR(Xcons
),T_NO_K
,ground
, "mcons")
3367 return mcons (a
, b
);
3370 /*_ . Parts and operations */
3372 SIG_CHKARRAY(pair_cxr
) = { REF_OPER(is_pair
), };
3373 DEF_SIMPLE_DESTR(pair_cxr
);
3374 DEF_APPLICATIVE_W_DESTR(ps0a1
,pair_car
, REF_DESTR(pair_cxr
),T_NO_K
,ground
, "car")
3377 return v2car(sc
,T_PAIR
,p
);
3380 DEF_APPLICATIVE_W_DESTR(ps0a1
,pair_cdr
, REF_DESTR(pair_cxr
),T_NO_K
,ground
, "cdr")
3383 return v2cdr(sc
,T_PAIR
,p
);
3386 SIG_CHKARRAY(pair_set_cxr
) = { REF_OPER(is_pair
), K_ANY
, };
3387 DEF_SIMPLE_DESTR(pair_set_cxr
);
3388 DEF_APPLICATIVE_W_DESTR(ps0a2
,set_car
, REF_DESTR(pair_set_cxr
),T_NO_K
,ground
, "set-car!")
3391 v2set_car(sc
,T_PAIR
,p
,q
);
3395 DEF_APPLICATIVE_W_DESTR(ps0a2
,set_cdr
, REF_DESTR(pair_set_cxr
),T_NO_K
,ground
, "set-cdr!")
3398 v2set_cdr(sc
,T_PAIR
,p
,q
);
3401 /*_ , Normal (one arg) */
3402 /*_ , Values as pairs */
3403 DEF_CFUNC_RAW(OPER (valcar
), ps0a1
, pair_car
, REF_OPER (is_pair
), T_NO_K
);
3404 DEF_CFUNC_RAW(OPER (valcdr
), ps0a1
, pair_cdr
, REF_OPER (is_pair
), T_NO_K
);
3408 DEF_T_PRED (is_string
, T_STRING
,ground
,"string?/o1");
3411 INTERFACE INLINE pko
3412 mk_string (const char *str
)
3414 return mk_bastring (T_STRING
, str
, strlen (str
), 0);
3417 INTERFACE INLINE pko
3418 mk_counted_string (const char *str
, int len
)
3420 return mk_bastring (T_STRING
, str
, len
, 0);
3423 INTERFACE INLINE pko
3424 mk_empty_string (int len
, char fill
)
3426 return mk_bastring (T_STRING
, 0, len
, fill
);
3428 /*_ . Create static */
3429 /* $$WRITE ME As for k_print_terminate_list macros */
3432 INTERFACE INLINE
char *
3433 string_value (pko p
)
3435 return bastring_value(0,T_STRING
,p
);
3438 INTERFACE INLINE
int
3441 return bastring_len(0,T_STRING
,p
);
3446 DEF_T_PRED(is_symbol
, T_SYMBOL
,ground
,"symbol?/o1");
3449 mk_symbol_obj (const char *name
)
3451 return mk_bastring (T_SYMBOL
| T_IMMUTABLE
, name
, strlen (name
), 0);
3454 /* We want symbol objects to be unique per name, so check an oblist of
3457 mk_symbol (const char *name
)
3459 /* first check oblist */
3460 pko x
= oblist_find_by_name (name
);
3467 x
= oblist_add_by_name (name
);
3471 /*_ . oblist implementation */
3472 /*_ , Global object */
3473 static pko oblist
= 0;
3474 /*_ , Oblist as hash table */
3475 #ifndef USE_OBJECT_LIST
3477 static int hash_fn (const char *key
, int table_size
);
3480 oblist_initial_value ()
3482 return mk_vector (461, K_NIL
);
3485 /* returns the new symbol */
3487 oblist_add_by_name (const char *name
)
3489 pko x
= mk_symbol_obj (name
);
3490 int location
= hash_fn (name
, vector_len (oblist
));
3491 set_vector_elem (oblist
, location
,
3492 cons (x
, vector_elem (oblist
, location
)));
3497 oblist_find_by_name (const char *name
)
3504 location
= hash_fn (name
, vector_len (oblist
));
3505 for (x
= vector_elem (oblist
, location
); x
!= K_NIL
; x
= cdr (x
))
3507 s
= symname (0,car (x
));
3508 /* case-insensitive, per R5RS section 2. */
3509 if (stricmp (name
, s
) == 0)
3518 oblist_all_symbols (void)
3522 pko ob_list
= K_NIL
;
3524 for (i
= 0; i
< vector_len (oblist
); i
++)
3526 for (x
= vector_elem (oblist
, i
); x
!= K_NIL
; x
= cdr (x
))
3528 ob_list
= mcons (x
, ob_list
);
3534 /*_ , Oblist as list */
3538 oblist_initial_value ()
3544 oblist_find_by_name (const char *name
)
3549 for (x
= oblist
; x
!= K_NIL
; x
= cdr (x
))
3551 s
= symname (0,car (x
));
3552 /* case-insensitive, per R5RS section 2. */
3553 if (stricmp (name
, s
) == 0)
3561 /* returns the new symbol */
3563 oblist_add_by_name (const char *name
)
3565 pko x
= mk_symbol_obj (name
);
3566 oblist
= cons (x
, oblist
);
3571 oblist_all_symbols (void)
3579 /*_ . Parts and operations */
3580 SIG_CHKARRAY(string_to_symbol
) = { REF_OPER(is_string
), };
3581 DEF_SIMPLE_APPLICATIVE(ps0a1
,string_to_symbol
,T_NO_K
,ground
, "string->symbol")
3583 return mk_symbol(string_value(arg1
));
3586 INTERFACE INLINE
char *
3587 symname (sc_or_null sc
, pko p
)
3589 return bastring_value (sc
,T_SYMBOL
, p
);
3596 DEF_T_PRED (is_vector
, T_VECTOR
,unsafe
,"vector?/o1");
3599 /*_ , mk_vector (T_ level) */
3600 INTERFACE
static pko
3601 mk_vector (int len
, pko fill
)
3602 { return mk_filled_basvector(len
, fill
, T_VECTOR
); }
3604 /*_ , k_mk_vector (K level) */
3605 /* $$RETHINK ME This may not be wanted. */
3606 SIG_CHKARRAY(k_mk_vector
) = { REF_OPER(is_integer
), REF_KEY(K_TYCH_OPTIONAL
), K_ANY
, };
3607 DEF_SIMPLE_APPLICATIVE (ps0a2
, k_mk_vector
,T_NO_K
,unsafe
,"make-vector")
3609 WITH_2_ARGS(k_len
, fill
);
3611 int len
= ivalue (k_len
);
3612 if (fill
== K_INERT
)
3614 return mk_vector (len
, fill
);
3618 /* K_ANY instead of REF_OPER(is_finite_list) because
3619 mk_basvector_w_args checks list-ness internally */
3620 DEF_APPLICATIVE_W_DESTR(ps0a1
, vector
, K_ANY
,T_NO_K
,unsafe
,"vector")
3623 return mk_basvector_w_args(sc
,p
,T_VECTOR
);
3626 /*_ . Operations (T_ level) */
3627 /*_ , fill_vector */
3629 INTERFACE
static void
3630 fill_vector (pko vec
, pko obj
)
3632 assert(_get_type(vec
) == T_VECTOR
);
3633 unsafe_basvector_fill(vec
,obj
);
3636 /*_ . Parts of vectors (T_ level) */
3638 INTERFACE
static int
3639 vector_len (pko vec
)
3641 assert(_get_type(vec
) == T_VECTOR
);
3642 return basvector_len(vec
);
3645 INTERFACE
static pko
3646 vector_elem (pko vec
, int ielem
)
3648 assert(_get_type(vec
) == T_VECTOR
);
3649 return basvector_elem(vec
, ielem
);
3652 INTERFACE
static void
3653 set_vector_elem (pko vec
, int ielem
, pko a
)
3655 assert(_get_type(vec
) == T_VECTOR
);
3656 basvector_set_elem(vec
, ielem
, a
);
3661 /* T_PROMISE is essentially a handle, pointing to a pair of either
3662 (expression env) or (value #f). We use #f, not nil, because nil is
3663 a possible environment. */
3667 RGSTR(ground
,"$lazy", REF_OPER(mk_promise_lazy
))
3668 DEF_CFUNC(ps0a1
, mk_promise_lazy
, K_ANY_SINGLETON
, T_NO_K
)
3671 pko guts
= mcons(p
, mcons(sc
->envir
, mk_continuation(sc
->dump
)));
3672 return v2cons (T_PROMISE
, guts
, K_NIL
);
3675 /* $$CHECK ME Is K_ANY correct? Or K_ANY_SINGLETON? */
3676 DEF_APPLICATIVE_W_DESTR(p00a1
,mk_promise_memo
,K_ANY
,T_NO_K
,ground
,"memoize")
3679 pko guts
= mcons(p
, K_F
);
3680 return v2cons (T_PROMISE
, guts
, K_NIL
);
3684 DEF_T_PRED (is_promise
,T_PROMISE
,ground
,"promise?/o1");
3686 /*_ , promise_schedule_eval */
3688 promise_schedule_eval(klink
* sc
, pko p
)
3691 pko guts
= unsafe_v2car(p
);
3692 pko env
= car(cdr(guts
));
3693 pko dynxtnt
= cdr(cdr(guts
));
3694 /* Arrange to eval the expression and pass the result to
3695 handle_promise_result */
3696 CONTIN_1R(dcrry_2ALLVLL
,handle_promise_result
,sc
,p
);
3697 /* $$ENCAP ME This deals with continuation guts, so should be
3698 encapped. As a special continuation-maker? */
3699 _kt_spagstack new_dump
=
3700 special_dynxtnt (cont_dump(dynxtnt
), sc
->dump
, env
);
3701 sc
->dump
= new_dump
;
3702 CONTIN_2(dcrry_2dotALL
, kernel_eval
, sc
, car(guts
), env
);
3705 /*_ , handle_promise_result */
3706 SIG_CHKARRAY(handle_promise_result
) = { REF_OPER(is_promise
), K_ANY
};
3707 DEF_SIMPLE_CFUNC(ps0a2
,handle_promise_result
,0)
3709 /* guts are only made by C code so if they're wrong it's a C
3712 WITH_2_ARGS(p
,value
);
3713 pko guts
= unsafe_v2car(p
);
3715 /* if p already has a result, return it */
3716 if(cdr(guts
) == K_F
)
3717 { return car(guts
); }
3718 /* If value is again a promise, set this promise's guts to that
3719 promise's guts and force it again, which will force both (This is
3720 why we need promises to be 2-layer) */
3721 else if(is_promise(value
))
3723 unsafe_v2set_car (p
, unsafe_v2car(value
));
3724 return promise_schedule_eval(sc
, p
);
3726 /* Otherwise set the value and return it. */
3729 unsafe_v2set_car (guts
, value
);
3730 unsafe_v2set_cdr (guts
, K_F
);
3736 DEF_APPLICATIVE_W_DESTR (ps0a1
, force
, K_ANY_SINGLETON
,T_NO_K
,ground
,"force")
3738 /* guts are only made by this C code here, so if they're wrong it's
3745 pko guts
= unsafe_v2car(p
);
3746 if(cdr(guts
) == K_F
)
3747 { return car(guts
); }
3749 { return promise_schedule_eval(sc
,p
); }
3755 /* $$IMPROVE ME Just directly contain the port structure. Possibly
3756 split port into several T_ types. */
3760 ALLOC_BOX_PRESUME (port
*, T_PORT
);
3762 return PTR2PKO(pbox
);
3766 port_rep_from_filename (const char *fn
, int prop
)
3771 if (prop
== (port_input
| port_output
))
3775 else if (prop
== port_output
)
3788 pt
= port_rep_from_file (f
, prop
);
3789 pt
->rep
.stdio
.closeit
= 1;
3793 { pt
->rep
.stdio
.filename
= store_string (strlen (fn
), fn
, 0); }
3795 pt
->rep
.stdio
.curr_line
= 0;
3801 port_from_filename (const char *fn
, int prop
)
3804 pt
= port_rep_from_filename (fn
, prop
);
3809 return mk_port (pt
);
3813 port_rep_from_file (FILE * f
, int prop
)
3816 pt
= (port
*) GC_MALLOC_ATOMIC (sizeof *pt
);
3821 /* Don't care what goes in these but GC really wants to provide it
3822 so here are dummy objects to put it in. */
3823 GC_finalization_proc ofn
;
3825 GC_register_finalizer(pt
, port_finalize_file
, 0, &ofn
, &ocd
);
3826 pt
->kind
= port_file
| prop
;
3827 pt
->rep
.stdio
.file
= f
;
3828 pt
->rep
.stdio
.closeit
= 0;
3833 port_from_file (FILE * f
, int prop
)
3836 pt
= port_rep_from_file (f
, prop
);
3841 return mk_port (pt
);
3845 port_rep_from_string (char *start
, char *past_the_end
, int prop
)
3848 pt
= (port
*) GC_MALLOC_ATOMIC (sizeof (port
));
3853 pt
->kind
= port_string
| prop
;
3854 pt
->rep
.string
.start
= start
;
3855 pt
->rep
.string
.curr
= start
;
3856 pt
->rep
.string
.past_the_end
= past_the_end
;
3861 port_from_string (char *start
, char *past_the_end
, int prop
)
3864 pt
= port_rep_from_string (start
, past_the_end
, prop
);
3869 return mk_port (pt
);
3872 #define BLOCK_SIZE 256
3875 realloc_port_string (port
* p
)
3877 /* $$IMPROVE ME Just use REALLOC. */
3878 char *start
= p
->rep
.string
.start
;
3879 size_t new_size
= p
->rep
.string
.past_the_end
- start
+ 1 + BLOCK_SIZE
;
3880 char *str
= GC_MALLOC_ATOMIC (new_size
);
3883 memset (str
, ' ', new_size
- 1);
3884 str
[new_size
- 1] = '\0';
3885 strcpy (str
, start
);
3886 p
->rep
.string
.start
= str
;
3887 p
->rep
.string
.past_the_end
= str
+ new_size
- 1;
3888 p
->rep
.string
.curr
-= start
- str
;
3899 port_rep_from_scratch (void)
3903 pt
= (port
*) GC_MALLOC_ATOMIC (sizeof (port
));
3908 start
= GC_MALLOC_ATOMIC (BLOCK_SIZE
);
3913 memset (start
, ' ', BLOCK_SIZE
- 1);
3914 start
[BLOCK_SIZE
- 1] = '\0';
3915 pt
->kind
= port_string
| port_output
| port_srfi6
;
3916 pt
->rep
.string
.start
= start
;
3917 pt
->rep
.string
.curr
= start
;
3918 pt
->rep
.string
.past_the_end
= start
+ BLOCK_SIZE
- 1;
3923 port_from_scratch (void)
3926 pt
= port_rep_from_scratch ();
3931 return mk_port (pt
);
3934 /*_ . open-input-file */
3935 SIG_CHKARRAY(k_open_input_file
) =
3936 { REF_OPER(is_string
), };
3937 DEF_SIMPLE_APPLICATIVE(ps0a1
,k_open_input_file
,0,ground
, "open-input-file")
3939 WITH_1_ARGS(filename
);
3940 return port_from_filename (string_value(filename
), port_file
| port_input
);
3946 DEF_T_PRED (is_port
, T_PORT
,ground
,"port?/o1");
3948 DEF_SIMPLE_PRED (is_inport
,T_NO_K
,ground
,"input-port?/o1")
3951 return is_port (p
) && portvalue (p
)->kind
& port_input
;
3954 DEF_SIMPLE_PRED (is_outport
,T_NO_K
,ground
,"output-port?/o1")
3957 return is_port (p
) && portvalue (p
)->kind
& port_output
;
3964 WITH_PSYC_UNBOXED(port
*,p
,T_PORT
,0);
3969 set_portvalue (pko p
, port
* newport
)
3971 assert_mutable(0,p
);
3972 WITH_PSYC_UNBOXED(port
*,p
,T_PORT
,0);
3977 /*_ . reading from ports */
3983 if (pt
->kind
& port_saw_EOF
)
3985 c
= basic_inchar (pt
);
3987 { pt
->kind
|= port_saw_EOF
; }
3991 if (pt
->kind
& port_file
)
3992 { pt
->rep
.stdio
.curr_line
++; }
4000 basic_inchar (port
* pt
)
4002 if (pt
->kind
& port_file
)
4004 return fgetc (pt
->rep
.stdio
.file
);
4008 if (*pt
->rep
.string
.curr
== 0 ||
4009 pt
->rep
.string
.curr
== pt
->rep
.string
.past_the_end
)
4015 return *pt
->rep
.string
.curr
++;
4020 /* back character to input buffer */
4022 backchar (port
* pt
, int c
)
4027 if (pt
->kind
& port_file
)
4029 ungetc (c
, pt
->rep
.stdio
.file
);
4033 pt
->rep
.stdio
.curr_line
--;
4039 if (pt
->rep
.string
.curr
!= pt
->rep
.string
.start
)
4041 --pt
->rep
.string
.curr
;
4048 /*_ . (get-char textual-input-port) */
4049 SIG_CHKARRAY(get_char
) = { REF_OPER(is_inport
), };
4050 DEF_SIMPLE_APPLICATIVE(p00a1
,get_char
,T_NO_K
,ground
, "get-char")
4053 assert(is_inport(port
));
4054 int c
= inchar(portvalue(port
));
4058 { return mk_character(c
); }
4061 /*_ . Finalization */
4063 port_finalize_file(GC_PTR obj
, GC_PTR client_data
)
4066 if ((pt
->kind
& port_file
) && pt
->rep
.stdio
.closeit
)
4067 { port_close_port (pt
, port_input
| port_output
); }
4071 port_close (pko p
, int flag
)
4074 port_close_port(portvalue (p
), flag
);
4078 port_close_port (port
* pt
, int flag
)
4081 if ((pt
->kind
& (port_input
| port_output
)) == 0)
4083 if (pt
->kind
& port_file
)
4086 /* Cleanup is here so (close-*-port) functions could work too */
4087 pt
->rep
.stdio
.curr_line
= 0;
4091 fclose (pt
->rep
.stdio
.file
);
4093 pt
->kind
= port_free
;
4098 /*_ , Encapsulation type */
4100 SIG_CHKARRAY(is_encap
) = { REF_OPER(is_key
), K_ANY
};
4101 DEF_SIMPLE_CFUNC(b00a2
, is_encap
,T_NO_K
)
4103 WITH_2_ARGS(type
, p
);
4104 if (is_type (p
, T_ENCAP
))
4106 WITH_UNBOXED_UNSAFE(pdata
,kt_encap
,p
);
4107 return (pdata
->type
== type
);
4115 /* NOT directly part of the interface. */
4116 SIG_CHKARRAY(unencap
) = { REF_OPER(is_key
), K_ANY
};
4117 DEF_SIMPLE_CFUNC(ps0a2
, unencap
,T_NO_K
)
4119 WITH_2_ARGS(type
, p
);
4120 if (is_encap (type
, p
))
4122 WITH_UNBOXED_UNSAFE(pdata
,kt_encap
,p
);
4123 return pdata
->value
;
4127 /* We have no type-name to give to the error message. */
4128 KERNEL_ERROR_0 (sc
, "unencap: wrong type");
4132 /* NOT directly part of the interface. */
4133 SIG_CHKARRAY(mk_encap
) = { REF_OPER(is_key
), K_ANY
};
4134 DEF_SIMPLE_CFUNC(p00a2
, mk_encap
,T_NO_K
)
4136 WITH_2_ARGS(type
, value
);
4137 ALLOC_BOX_PRESUME (kt_encap
, T_ENCAP
);
4138 pbox
->data
.type
= type
;
4139 pbox
->data
.value
= value
;
4140 return PTR2PKO(pbox
);
4143 DEF_APPLICATIVE_W_DESTR (p00a0
, mk_encapsulation_type
, K_NO_TYPE
,T_NO_K
,ground
, "make-encapsulation-type/raw")
4145 /* A unique cell representing a type */
4146 pko type
= mk_void();
4147 /* $$IMPROVE ME make typespecs for the curried objs. trivpred is
4148 effectively that spec object. */
4149 pko e
= wrap (mk_curried (dcrry_2ALLV01
, type
, REF_OPER (mk_encap
)));
4150 pko trivpred
= mk_curried (dcrry_2ALLV01
, type
, REF_OPER (is_encap
));
4151 pko d
= wrap (mk_curried (dcrry_2ALLV01
, type
, REF_OPER (unencap
)));
4152 return LIST3 (e
, trivpred
, d
);
4154 /*_ , Listloop types */
4155 /*_ . Forward declarations */
4157 /*_ . Enumerations */
4159 /* How to turn the current list into current value and next list. */
4166 } kt_loopstyle_step
;
4174 } kt_loopstyle_argix
;
4176 /*_ . Function signatures. */
4177 typedef pko (* kt_listloop_mk_val
)(pko value
, struct kt_listloop
* pll
);
4179 typedef struct kt_listloop_style
4181 pko combiner
; /* Default combiner or NULL. */
4182 int collect_p
; /* Whether to collect a (reversed)
4183 list of the returns. */
4184 kt_loopstyle_step step
;
4185 kt_listloop_mk_val mk_val
; /* From returned value+state -> passed value. */
4186 pko destructurer
; /* A destructurer contents */
4187 /* Selection of args. Each entry correspond to one arg in "full
4188 args", and indexes something in the array of actual args that the
4189 destructurer retrieves. */
4190 int arg_select
[lls_num_args
];
4191 } kt_listloop_style
;
4192 typedef struct kt_listloop
4194 pko combiner
; /* The combiner to use repeatedly. */
4195 pko list
; /* The list to loop over */
4196 int top_length
; /* Length of top element, for lls_many. */
4197 int countdown
; /* Num elements left, or negative if unused. */
4198 int countup
; /* Upwards count from 0. */
4199 pko stop_on
; /* Stop if return value is this. Can
4201 kt_listloop_style
* style
; /* Non-NULL pointer to style. */
4203 /*_ , Internal signatures */
4205 listloop_aux (klink
* sc
,
4206 kt_listloop_style
* style_v
,
4208 pko style_args
[lls_num_args
]);
4209 FORWARD_DECL_CFUNC (static, ps0a3
, listloop_resume
);
4212 /*_ , Listloop styles */
4218 kt_loopstyle_step step
,
4219 kt_listloop_mk_val mk_val
)
4221 ALLOC_BOX_PRESUME(kt_listloop_style
,T_LISTLOOP_STYLE
);
4222 pdata
->combiner
= combiner
;
4223 pdata
->collect_p
= collect_p
;
4225 pdata
->mk_val
= mk_val
;
4226 return PTR2PKO(pbox
);
4236 kt_listloop_style
* style
)
4238 ALLOC_BOX_PRESUME(kt_listloop
,T_LISTLOOP
);
4239 pdata
->combiner
= combiner
;
4241 pdata
->top_length
= top_length
;
4242 pdata
->countdown
= count
;
4243 pdata
->countup
= -1;
4244 pdata
->stop_on
= stop_on
;
4245 pdata
->style
= style
;
4246 return PTR2PKO(pbox
);
4250 copy_listloop(const kt_listloop
* orig
)
4252 ALLOC_BOX_PRESUME(kt_listloop
,T_LISTLOOP
);
4253 memcpy (pdata
, orig
, sizeof(kt_listloop
));
4254 return PTR2PKO(pbox
);
4258 DEF_T_PRED(is_listloop
, T_LISTLOOP
, no
, "");
4259 DEF_T_PRED(is_listloop_style
, T_LISTLOOP_STYLE
, no
, "");
4261 /*_ . Pre-existing style objects */
4262 /*_ , listloop-style-sequence */
4263 RGSTR(simple
,"listloop-style-sequence",REF_OBJ(sequence_style
))
4264 static BOX_OF(kt_listloop_style
) sequence_style
=
4268 REF_OPER(kernel_eval
),
4272 K_NO_TYPE
, /* No args contemplated */
4273 { [0 ... lls_num_args
- 1] = -1, }
4276 /*_ , listloop-style-neighbors */
4277 RGSTR(simple
,"listloop-style-neighbors",REF_OBJ(neighbor_style
))
4278 SIG_CHKARRAY(neighbor_style
) =
4280 REF_OPER(is_integer
),
4282 DEF_SIMPLE_DESTR(neighbor_style
);
4283 static BOX_OF(kt_listloop_style
) neighbor_style
=
4291 REF_DESTR(neighbor_style
),
4292 /* See http://gcc.gnu.org/onlinedocs/gcc/Designated-Inits.html. */
4293 { [0 ... lls_num_args
- 1] = -1, [lls_count
] = 0, },
4298 /* Create a listloop object. */
4299 /* $$IMPROVE ME This may become what style operative T_ type calls.
4300 Rename it eval_listloop_style. */
4301 SIG_CHKARRAY(listloop
) =
4303 REF_OPER(is_listloop_style
),
4304 REF_OPER(is_countable_list
),
4305 REF_KEY(K_TYCH_DOT
),
4309 DEF_SIMPLE_APPLICATIVE(ps0a3
, listloop
,0,ground
, "listloop")
4311 WITH_3_ARGS(style
, list
, args
);
4313 WITH_UNBOXED_UNSAFE(style_v
,kt_listloop_style
, style
);
4314 pko style_args
[lls_num_args
];
4315 /* Destructure the args by style */
4316 destructure_to_array(sc
,
4318 style_v
->destructurer
,
4321 REF_OPER (listloop_resume
),
4322 LIST2 (style
, list
));
4323 return listloop_aux (sc
, style_v
, list
, style_args
);
4325 /*_ , listloop_resume */
4326 SIG_CHKARRAY (listloop_resume
) =
4328 REF_OPER (is_destr_result
),
4329 REF_OPER(is_listloop_style
),
4330 REF_OPER(is_countable_list
),
4332 DEF_SIMPLE_CFUNC(ps0a3
, listloop_resume
, 0)
4334 WITH_3_ARGS (destr_result
, style
, list
);
4335 pko style_args
[lls_num_args
];
4336 destr_result_fill_array (destr_result
, lls_num_args
, style_args
);
4337 WITH_UNBOXED_UNSAFE(style_v
,kt_listloop_style
, style
);
4338 return listloop_aux (sc
, style_v
, list
, style_args
);
4340 /*_ , listloop_aux */
4343 (klink
* sc
, kt_listloop_style
* style_v
, pko list
, pko style_args
[lls_num_args
])
4345 /*** Get the actual arg objects ***/
4346 #define GET_OBJ(_INDEX) \
4347 ((style_v->arg_select[_INDEX] < 0) ? K_INERT : style_args[style_v->arg_select[_INDEX]])
4349 pko count
= GET_OBJ(lls_count
);
4350 pko combiner
= GET_OBJ(lls_combiner
);
4351 pko top_length
= GET_OBJ(lls_top_count
);
4354 /*** Extract values from the objects, using defaults as needed ***/
4355 int countv
= (count
== K_INERT
) ? -1L : ivalue(count
);
4356 int top_lengthv
= (top_length
== K_INERT
) ? 1 : ivalue(top_length
);
4357 if(combiner
== K_INERT
)
4359 combiner
= style_v
->combiner
;
4362 /*** Make the loop object itself ***/
4363 pko ll
= mk_listloop( combiner
, list
, top_lengthv
, countv
, 0, style_v
);
4366 /*_ , Evaluating one iteration */
4368 eval_listloop(klink
* sc
, pko functor
, pko value
)
4371 WITH_PSYC_UNBOXED(kt_listloop
, functor
, T_LISTLOOP
, sc
);
4373 /*** Test whether done, maybe return current value. ***/
4374 /* If we're not checking, value will be NULL so this won't
4375 trigger. pdata->countup is 0 for the first element. */
4376 if((pdata
->countup
>= 0) && (value
== pdata
->stop_on
))
4378 /* $$IMPROVE ME This will ct an "abnormal return" value from
4379 this and the other data. */
4382 /* If we're not counting down, value will be negative so this won't
4384 if(pdata
->countdown
== 0)
4388 /* And if we run out of elements, we have to stop regardless. */
4389 if(pdata
->list
== K_NIL
)
4391 /* $$IMPROVE ME Error if we're counting down (ie, if count
4396 /*** Step list, getting new value ***/
4397 pko new_list
, new_value
;
4399 switch(pdata
->style
->step
)
4402 new_list
= cdr( pdata
->list
);
4403 /* We assume the common case of val as list. */
4404 new_value
= LIST1(car( pdata
->list
));
4408 /* $$IMPROVE ME Also test that next item (new_list) is non-empty */
4409 new_list
= cdr( pdata
->list
);
4410 new_value
= LIST2(car( pdata
->list
), car(new_list
));
4413 new_list
= k_counted_map_cdr(sc
, pdata
->top_length
, pdata
->list
, T_PAIR
);
4414 new_value
= k_counted_map_car(sc
, pdata
->top_length
, pdata
->list
, T_PAIR
);
4417 KERNEL_ERROR_0(sc
,"I know nut-ting about that case");
4420 /* Convert it if applicable. */
4421 if(pdata
->style
->mk_val
)
4423 new_value
= pdata
->style
->mk_val(new_value
, pdata
);
4426 /*** Arrange a new iteration. ***/
4427 /* We don't have to re-setup the final chain, if any, because it's
4428 still there from the earlier call. Just the combiner (if any)
4429 and a fresh listloop operative. */
4430 pko new_listloop
= copy_listloop(pdata
);
4432 WITH_UNBOXED_UNSAFE(new_pdata
,kt_listloop
,new_listloop
);
4433 new_pdata
->list
= new_list
;
4434 if(new_pdata
->countdown
> 0)
4435 { new_pdata
->countdown
--; }
4436 new_pdata
->countup
++;
4439 if(pdata
->style
->collect_p
)
4441 CONTIN_0_RAW (mk_curried(dcrry_NVLLdotALL
, value
, new_listloop
), sc
);
4445 CONTIN_0_RAW(new_listloop
, sc
);
4448 CONTIN_0_RAW(pdata
->combiner
, sc
);
4452 /*_ . Handling lists */
4454 DEF_APPLICATIVE_W_DESTR (ps0a1
, list_star
, REF_OPER(is_finite_list
),T_NO_K
,ground
, "list*")
4456 return v2list_star(sc
, arg1
, T_PAIR
);
4459 SIG_CHKARRAY(reverse
) = { REF_OPER(is_finite_list
), };
4460 DEF_SIMPLE_APPLICATIVE (ps0a1
, reverse
,T_NO_K
,ground
, "reverse")
4463 return v2reverse(a
,T_PAIR
);
4465 /*_ . reverse list -- in-place */
4466 /* Don't just use unsafe_v2reverse_in_place, it checks nothing. This
4467 may be reserved for optimization only. */
4469 /*_ . append list -- produce new list */
4470 /* $$IMPROVE ME This defines append/2 but we'll want append/N. Do
4472 SIG_CHKARRAY(append
) = { REF_OPER(is_finite_list
), K_ANY
, };
4473 DEF_SIMPLE_APPLICATIVE (ps0a2
, append
,T_NO_K
,simple
, "append")
4476 return v2append(sc
,a
,b
,T_PAIR
);
4478 /*_ , is_finite_list */
4479 DEF_SIMPLE_PRED (is_finite_list
,T_NO_K
,ground
, "finite-list?/o1")
4483 get_list_metrics_aux(p
, metrics
);
4484 return (metrics
[lm_num_nils
] == 1);
4486 /*_ , is_countable_list */
4487 DEF_SIMPLE_PRED (is_countable_list
,T_NO_K
,ground
, "countable-list?/o1")
4491 get_list_metrics_aux(p
, metrics
);
4492 return (metrics
[lm_num_nils
] || metrics
[lm_cyc_len
]);
4494 /*_ , list_length */
4499 dotted list: -2 minus length before dot
4501 The extra meanings will change since callers can use
4502 get_list_metrics_aux now. Return lm_acyc_len even for dotted
4503 lists, return positive infinity for circular lists.
4510 get_list_metrics_aux(p
, metrics
);
4512 if(metrics
[lm_num_nils
] == 1)
4513 { return metrics
[lm_acyc_len
]; }
4514 /* A circular list */
4515 /* $$IMPROVE ME Return +oo. First make a type and object for +oo */
4516 if(metrics
[lm_cyc_len
] != 0)
4518 /* $$IMPROVE ME Return lm_acyc_len again, merge with the other
4520 /* Otherwise it's dotted */
4521 return 2 - metrics
[lm_acyc_len
];
4523 /*_ , list_length_k */
4524 DEF_APPLICATIVE_W_DESTR(p00a1
, list_length_k
, K_ANY_SINGLETON
,T_NO_K
,ground
, "length")
4527 return mk_integer(list_length(p
));
4530 /*_ , get_list_metrics */
4531 DEF_APPLICATIVE_W_DESTR(p00a1
, get_list_metrics
, K_ANY_SINGLETON
,T_NO_K
,ground
, "get-list-metrics")
4535 get_list_metrics_aux(p
, metrics
);
4536 return LIST4(mk_integer(metrics
[0]),
4537 mk_integer(metrics
[1]),
4538 mk_integer(metrics
[2]),
4539 mk_integer(metrics
[3]));
4541 /*_ , get_list_metrics_aux */
4542 /* RESULTS must be an int4 (an array of 4 integers). get_list_metrics_aux
4543 will fill it with (See enum lm_index):
4545 * the number of pairs in a
4546 * the number of nil objects in a
4547 * the acyclic prefix length of a
4548 * the cycle length of a
4551 /* $$IMPROVE ME Take a flag so we can skip work such as finding
4552 prefix-length when we don't need to do it. This will cause some
4553 result positions to be interpreted differently: when it's cycling,
4554 lm_acyc_len and lm_num_pairs may both overshoot (but never
4559 get_list_metrics_aux (pko a
, int4 presults
)
4561 int * results
= presults
; /* Make it easier to index. */
4568 /* Use Brent's Algorithm, but we have to check for nil and non-pair
4569 too, so I rearranged the loop. We also count steps, because in
4570 some cases we use number of steps directly. */
4576 results
[lm_num_pairs
] = steps
;
4577 results
[lm_num_nils
] = 1;
4578 results
[lm_acyc_len
] = steps
;
4579 results
[lm_cyc_len
] = 0;
4582 if (!is_pair (fast
))
4584 results
[lm_num_pairs
] = steps
;
4585 results
[lm_num_nils
] = 0;
4586 results
[lm_acyc_len
] = steps
;
4587 results
[lm_cyc_len
] = 0;
4593 /* The fast cursor has caught up with the slow cursor so the
4594 structure is circular and loop_len is the cycle length.
4595 We still need to find prefix length.
4599 /* Restart the turtle from the beginning */
4601 /* Restart the hare from position LOOP_LEN */
4602 for(i
= 0, fast
= a
; i
< loop_len
; i
++)
4603 { fast
= cdr (fast
); }
4604 /* Since hare has exactly a loop_len head start, when it
4605 goes around the loop exactly once it will be in the same
4606 position as turtle, so turtle will have only walked the
4615 results
[lm_num_pairs
] = prefix_len
+ loop_len
;
4616 results
[lm_num_nils
] = 0;
4617 results
[lm_acyc_len
] = prefix_len
;
4618 results
[lm_cyc_len
] = loop_len
;
4621 if(power
== loop_len
)
4623 /* Re-plant the slow cursor */
4632 /*_ . Handling trees */
4633 /*_ , copy_es_immutable */
4634 DEF_APPLICATIVE_W_DESTR (ps0a1
, copy_es_immutable
, K_ANY_SINGLETON
,T_NO_K
,ground
, "copy-es-immutable")
4636 WITH_1_ARGS(object
);
4638 if (is_pair (object
))
4640 /* If it's already immutable, can we assume it's immutable
4641 * all the way down and just return it? */
4643 (copy_es_immutable (sc
, car (object
)),
4644 copy_es_immutable (sc
, cdr (object
)));
4651 /*_ , Get tree cycles */
4653 /*_ , kt_recurrence_table */
4654 /* Really just a specialized resizeable lookup table from object to
4655 count. Internals may change. */
4656 /* $$IMPROVE ME Look up more efficiently. Current GC is not
4657 compacting, so we can hash or sort addresses meaningfully. */
4665 kt_recurrence_table
;
4666 /*_ , recur_entry */
4669 /* $$IMPROVE ME These two fields may become one enumerated field */
4674 /*_ , kt_recur_tracker */
4678 recur_entry
* entries
;
4682 /*_ . is_recurrence_table */
4683 DEF_T_PRED(is_recurrence_table
,T_RECURRENCES
,ground
, "recurrence-table?/o1");
4685 /*_ . is_recur_tracker */
4686 DEF_SIMPLE_PRED(is_recur_tracker
,T_NO_K
,ground
, "recur-tracker?/o1")
4689 return (p
== K_NIL
) || is_type (p
, T_RECUR_TRACKER
);
4691 /*_ . recurrences_to_recur_tracker */
4692 SIG_CHKARRAY(recurrences_to_recur_tracker
) =
4693 { REF_OPER(is_recurrence_table
), };
4694 DEF_SIMPLE_APPLICATIVE(p00a1
,recurrences_to_recur_tracker
,T_NO_K
,ground
, "recurrences->tracker")
4696 WITH_1_ARGS(recurrences
);
4697 assert_type(0,recurrences
,T_RECURRENCES
);
4699 WITH_UNBOXED_UNSAFE(ptable
, kt_recurrence_table
,recurrences
);
4700 /* $$IMPROVE ME Scan for counts > 1, and if there are none,
4702 if(ptable
->table_size
== 0)
4705 ALLOC_BOX_PRESUME(kt_recur_tracker
,T_RECUR_TRACKER
);
4706 /* $$MAKE ME SAFE This assumes that sharing is OK, recurrences
4707 won't mutate the LUT. When we have COW or similar, make it
4708 safe. At least check for immutability. */
4709 pdata
->objs
= ptable
->objs
;
4710 pdata
->table_size
= ptable
->table_size
;
4711 pdata
->current_index
= 0;
4713 GC_MALLOC_ATOMIC(sizeof(recur_entry
) * ptable
->table_size
);
4715 for(i
= 0; i
< ptable
->table_size
; i
++)
4717 recur_entry
* p_entry
= &pdata
->entries
[i
];
4718 p_entry
->count
= ptable
->counts
[i
];
4719 p_entry
->index_in_walk
= 0;
4720 p_entry
->seen_in_walk
= 0;
4722 return PTR2PKO(pbox
);
4725 /*_ . recurrences_list_objects */
4726 /* $$WRITE ME Get a list of all objects and their recurrence counts */
4727 /*_ . objtable_get_index */
4730 (pko
* objs
, int table_size
, pko obj
)
4733 for(i
= 0; i
< table_size
; i
++)
4740 /*_ . recurrences_get_seen_count */
4741 /* Return the number of times OBJ has been seen before. If "add" is
4742 non-zero, increment the count too (but return its previous
4745 recurrences_get_seen_count
4746 (kt_recurrence_table
* p_cycles_data
, pko obj
, int add
)
4748 int index
= objtable_get_index(p_cycles_data
->objs
,
4749 p_cycles_data
->table_size
,
4753 int count
= p_cycles_data
->counts
[index
];
4754 /* Maybe record another sighting of this object. */
4756 { p_cycles_data
->counts
[index
]++; }
4757 /* We've found our return value. */
4761 /* We only get here if search didn't find anything. */
4762 /* Make sure we have enough space for this object. */
4765 if(p_cycles_data
->table_size
== p_cycles_data
->alloced_size
)
4767 p_cycles_data
->alloced_size
*= 2;
4768 p_cycles_data
->counts
= GC_REALLOC(p_cycles_data
->counts
, sizeof(int) * p_cycles_data
->alloced_size
);
4769 p_cycles_data
->objs
= GC_REALLOC(p_cycles_data
->objs
, sizeof(pko
) * p_cycles_data
->alloced_size
);
4771 int index
= p_cycles_data
->table_size
;
4772 /* Record what it was */
4773 p_cycles_data
->objs
[index
] = obj
;
4774 /* We have now seen it once. */
4775 p_cycles_data
->counts
[index
] = 1;
4776 p_cycles_data
->table_size
++;
4780 /*_ . recurrences_get_object_count */
4781 /* Given an object, list its count */
4782 SIG_CHKARRAY(recurrences_get_object_count
) =
4783 { REF_OPER(is_recurrence_table
), K_ANY
, };
4784 DEF_SIMPLE_APPLICATIVE(p00a2
, recurrences_get_object_count
,T_NO_K
,ground
, "recurrences-get-object-count")
4786 WITH_2_ARGS(table
, obj
);
4787 WITH_PSYC_UNBOXED(kt_recurrence_table
,table
, T_RECURRENCES
, 0);
4788 int seen_count
= recurrences_get_seen_count(pdata
, obj
, 0);
4789 return mk_integer(seen_count
);
4791 /*_ . init_recurrence_table */
4793 init_recurrence_table(kt_recurrence_table
* p_cycles_data
, int initial_size
)
4795 p_cycles_data
->objs
= initial_size
?
4796 GC_MALLOC(sizeof(pko
) * initial_size
) : 0;
4797 p_cycles_data
->counts
= initial_size
?
4798 GC_MALLOC(sizeof(int) * initial_size
) : 0;
4799 p_cycles_data
->alloced_size
= initial_size
;
4800 p_cycles_data
->table_size
= 0;
4802 /*_ . trace_tree_cycles */
4805 (pko tree
, kt_recurrence_table
* p_cycles_data
)
4807 /* Special case for the "empty container", not because it's just a
4808 key but because "exploring" it does nothing. */
4811 /* Maybe skip this object entirely */
4812 /* $$IMPROVE ME Parameterize this */
4813 switch(_get_type(tree
))
4821 if(recurrences_get_seen_count(p_cycles_data
,tree
, 1) != 0)
4824 /* Switch on tree type */
4825 switch(_get_type(tree
))
4829 #define _EXPLORE_FUNC(X) trace_tree_cycles(X, p_cycles_data)
4831 #undef _EXPLORE_FUNC
4836 /* Done this exploration */
4841 /*_ . get_recurrences */
4842 SIG_CHKARRAY(get_recurrences
) = { K_ANY
, };
4843 DEF_SIMPLE_APPLICATIVE (ps0a1
, get_recurrences
,T_NO_K
,ground
, "get-recurrences")
4846 /* No reason to even start exploring non-containers */
4847 /* $$IMPROVE ME Allow containers other than pairs */
4848 int explore_p
= (_get_type(tree
) == T_PAIR
);
4849 ALLOC_BOX_PRESUME(kt_recurrence_table
, T_RECURRENCES
);
4850 init_recurrence_table(pdata
, explore_p
? 8 : 0);
4852 { trace_tree_cycles(tree
,pdata
); }
4853 return PTR2PKO(pbox
);
4858 /*_ , Making result objects */
4860 /* make symbol or number atom from string */
4862 mk_atom (klink
* sc
, char *q
)
4865 int has_dec_point
= 0;
4869 if ((p
= strstr (q
, "::")) != 0)
4872 return mcons (sc
->COLON_HOOK
,
4873 mcons (mcons (sc
->QUOTE
,
4874 mcons (mk_atom (sc
, p
+ 2), K_NIL
)),
4875 mcons (mk_symbol (strlwr (q
)), K_NIL
)));
4881 if ((c
== '+') || (c
== '-'))
4891 return (mk_symbol (strlwr (q
)));
4900 return (mk_symbol (strlwr (q
)));
4903 else if (!isdigit (c
))
4905 return (mk_symbol (strlwr (q
)));
4908 for (; (c
= *p
) != 0; ++p
)
4920 else if ((c
== 'e') || (c
== 'E'))
4924 has_dec_point
= 1; /* decimal point illegal
4927 if ((*p
== '-') || (*p
== '+') || isdigit (*p
))
4933 return (mk_symbol (strlwr (q
)));
4938 return mk_real (atof (q
));
4940 return (mk_integer (atol (q
)));
4945 mk_sharp_const (char *name
)
4948 char tmp
[STRBUFFSIZE
];
4950 if (!strcmp (name
, "t"))
4952 else if (!strcmp (name
, "f"))
4954 else if (!strcmp (name
, "ignore"))
4956 else if (!strcmp (name
, "inert"))
4958 else if (*name
== 'o')
4960 snprintf (tmp
, STRBUFFSIZE
, "0%s", name
+ 1);
4961 sscanf (tmp
, "%lo", &x
);
4962 return (mk_integer (x
));
4964 else if (*name
== 'd')
4965 { /* #d (decimal) */
4966 sscanf (name
+ 1, "%ld", &x
);
4967 return (mk_integer (x
));
4969 else if (*name
== 'x')
4971 snprintf (tmp
, STRBUFFSIZE
, "0x%s", name
+ 1);
4972 sscanf (tmp
, "%lx", &x
);
4973 return (mk_integer (x
));
4975 else if (*name
== 'b')
4977 x
= binary_decode (name
+ 1);
4978 return (mk_integer (x
));
4980 else if (*name
== '\\')
4981 { /* #\w (character) */
4983 if (stricmp (name
+ 1, "space") == 0)
4987 else if (stricmp (name
+ 1, "newline") == 0)
4991 else if (stricmp (name
+ 1, "return") == 0)
4995 else if (stricmp (name
+ 1, "tab") == 0)
4999 else if (name
[1] == 'x' && name
[2] != 0)
5002 if (sscanf (name
+ 2, "%x", &c1
) == 1 && c1
< UCHAR_MAX
)
5012 else if (is_ascii_name (name
+ 1, &c
))
5017 else if (name
[2] == 0)
5025 return mk_character (c
);
5031 /*_ , Reading strings */
5032 /* read characters up to delimiter, but cater to character constants */
5034 readstr_upto (klink
* sc
, char *delim
)
5036 port
* pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
5038 char *p
= sc
->strbuff
;
5040 while ((p
- sc
->strbuff
< sizeof (sc
->strbuff
)) &&
5041 !is_one_of (delim
, (*p
++ = inchar (pt
))));
5043 if (p
== sc
->strbuff
+ 2 && p
[-2] == '\\')
5049 backchar (pt
, p
[-1]);
5055 /* skip white characters */
5057 skipspace (klink
* sc
)
5059 port
* pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
5063 { c
= inchar (pt
); }
5064 while (isspace (c
));
5075 /* check c is in chars */
5077 is_one_of (char *s
, int c
)
5087 /*_ , Reading expressions */
5088 /* read string expression "xxx...xxx" */
5090 readstrexp (klink
* sc
)
5092 port
* pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
5093 char *p
= sc
->strbuff
;
5097 { st_ok
, st_bsl
, st_x1
, st_x2
, st_oct1
, st_oct2
} state
= st_ok
;
5102 if (c
== EOF
|| p
- sc
->strbuff
> sizeof (sc
->strbuff
) - 1)
5116 return mk_counted_string (sc
->strbuff
, p
- sc
->strbuff
);
5166 if (c
>= '0' && c
<= 'F')
5170 c1
= (c1
<< 4) + c
- '0';
5174 c1
= (c1
<< 4) + c
- 'A' + 10;
5193 if (c
< '0' || c
> '7')
5201 if (state
== st_oct2
&& c1
>= 32)
5204 c1
= (c1
<< 3) + (c
- '0');
5206 if (state
== st_oct1
)
5225 port
* pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
5232 switch (c
= inchar (pt
))
5237 return (TOK_LPAREN
);
5239 return (TOK_RPAREN
);
5242 if (is_one_of (" \n\t", c
))
5255 while ((c
= inchar (pt
)) != '\n' && c
!= EOF
)
5264 return (token (sc
));
5267 return (TOK_DQUOTE
);
5269 return (TOK_BQUOTE
);
5271 if ((c
= inchar (pt
)) == '@')
5273 return (TOK_ATMARK
);
5288 while ((c
= inchar (pt
)) != '\n' && c
!= EOF
)
5297 return (token (sc
));
5303 /* $$UNHACKIFY ME! This is a horrible hack. */
5304 if (is_one_of (" itfodxb\\", c
))
5306 return TOK_SHARP_CONST
;
5318 /*_ , Nesting check */
5319 /*_ . create_nesting_check */
5320 void create_nesting_check(klink
* sc
)
5321 { klink_push_dyn_binding(sc
,K_NEST_DEPTH
,mk_integer(0)); }
5322 /*_ . nest_depth_ok_p */
5323 int nest_depth_ok_p(klink
* sc
)
5326 klink_find_dyn_binding(sc
,K_NEST_DEPTH
);
5329 return ivalue(nesting
) == 0;
5331 /*_ . change_nesting_depth */
5332 void change_nesting_depth(klink
* sc
, signed int change
)
5335 klink_find_dyn_binding(sc
,K_NEST_DEPTH
);
5336 add_to_ivalue(nesting
,change
);
5338 /*_ , C-style entry points */
5340 /*_ . kernel_read_internal */
5341 /* The only reason that this is separate from kernel_read_sexp is that
5342 it gets a token, which kernel_read_sexp does almost always, except
5343 once when a caller tricks it with TOK_LPAREN, and once when
5344 kernel_read_list effectively puts back a token it didn't decode. */
5346 DEF_APPLICATIVE_W_DESTR (ps0a0
, kernel_read_internal
, K_NO_TYPE
,0,ground
, "read")
5348 token_t tok
= token (sc
);
5354 create_nesting_check(sc
);
5355 return kernel_read_sexp (sc
);
5358 /*_ . kernel_read_sexp */
5359 DEF_CFUNC (ps0a0
, kernel_read_sexp
, K_NO_TYPE
,0)
5367 CONTIN_0 (vector
, sc
);
5371 sc
->tok
= token (sc
);
5372 if (sc
->tok
== TOK_RPAREN
)
5376 else if (sc
->tok
== TOK_DOT
)
5378 KERNEL_ERROR_0 (sc
, "syntax error: illegal dot expression");
5382 change_nesting_depth(sc
, 1);
5383 CONTIN_1 (dcrry_2A01VLL
, kernel_read_list
, sc
, K_NIL
);
5384 CONTIN_0 (kernel_read_sexp
, sc
);
5389 pko pquote
= REF_OPER(arg1
);
5390 CONTIN_1 (dcrry_2A01VLL
, val2val
, sc
, pquote
);
5392 sc
->tok
= token (sc
);
5393 CONTIN_0 (kernel_read_sexp
, sc
);
5397 sc
->tok
= token (sc
);
5398 if (sc
->tok
== TOK_VEC
)
5400 /* $$CLEAN ME Do this more cleanly than by changing tokens
5401 to trick it. Maybe factor the TOK_LPAREN treatment so we
5403 klink_push_cont (sc
, REF_OPER (kernel_treat_qquoted_vec
));
5404 sc
->tok
= TOK_LPAREN
;
5405 /* $$CLEANUP Seems like this could be combined with the part
5407 CONTIN_0 (kernel_read_sexp
, sc
);
5412 /* Punt for now: Give quoted symbols rather than actual
5413 operators. ,Similarly sc->UNQUOTE, sc->UNQUOTESP */
5414 CONTIN_1 (dcrry_2A01VLL
, val2val
, sc
, sc
->QQUOTE
);
5417 CONTIN_0 (kernel_read_sexp
, sc
);
5421 CONTIN_1 (dcrry_2A01VLL
, val2val
, sc
, sc
->UNQUOTE
);
5422 sc
->tok
= token (sc
);
5423 CONTIN_0 (kernel_read_sexp
, sc
);
5426 CONTIN_1 (dcrry_2A01VLL
, val2val
, sc
, sc
->UNQUOTESP
);
5427 sc
->tok
= token (sc
);
5428 CONTIN_0 (kernel_read_sexp
, sc
);
5431 return mk_atom (sc
, readstr_upto (sc
, "();\t\n\r "));
5434 pko x
= readstrexp (sc
);
5437 KERNEL_ERROR_0 (sc
, "Error reading string");
5444 pko sharp_hook
= sc
->SHARP_HOOK
;
5446 is_symbol(sharp_hook
)
5447 ? find_slot_in_env (sc
->envir
, sharp_hook
, 1)
5451 KERNEL_ERROR_0 (sc
, "undefined sharp expression");
5455 pko form
= mcons (slot_value_in_env (f
), K_NIL
);
5456 return kernel_eval (sc
, form
, sc
->envir
);
5459 case TOK_SHARP_CONST
:
5461 pko x
= mk_sharp_const (readstr_upto (sc
, "();\t\n\r "));
5464 KERNEL_ERROR_0 (sc
, "undefined sharp expression");
5472 KERNEL_ERROR_0 (sc
, "syntax error: illegal token");
5477 /* $$IMPROVE ME Use currying ops instead of accumulating by hand */
5478 SIG_CHKARRAY(kernel_read_list
) = { REF_OPER(is_finite_list
), K_ANY
, };
5479 DEF_SIMPLE_CFUNC (ps0a2
, kernel_read_list
,0)
5481 WITH_2_ARGS (old_accum
,value
);
5482 pko accum
= mcons (value
, old_accum
);
5483 port
* pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
5484 sc
->tok
= token (sc
);
5485 if (sc
->tok
== TOK_EOF
)
5489 else if (sc
->tok
== TOK_RPAREN
)
5491 /* $$RECONSIDER ME Why is this done? To accept CR from user? */
5492 int c
= inchar (pt
);
5497 change_nesting_depth(sc
, -1);
5498 return (unsafe_v2reverse_in_place (K_NIL
, accum
));
5500 else if (sc
->tok
== TOK_DOT
)
5502 CONTIN_1 (dcrry_2A01VLL
, kernel_treat_dotted_list
, sc
, accum
);
5503 sc
->tok
= token (sc
);
5504 CONTIN_0 (kernel_read_sexp
, sc
);
5509 CONTIN_1 (dcrry_2A01VLL
, kernel_read_list
, sc
, accum
);
5510 CONTIN_0 (kernel_read_sexp
, sc
);
5515 /*_ . Treat end of dotted list */
5517 DEF_CFUNC (ps0a2
, kernel_treat_dotted_list
, REF_DESTR(kernel_read_list
),T_NO_K
)
5519 WITH_2_ARGS(args
,value
);
5521 if (token (sc
) != TOK_RPAREN
)
5523 KERNEL_ERROR_0 (sc
, "syntax error: illegal dot expression");
5527 change_nesting_depth(sc
, -1);
5528 return (unsafe_v2reverse_in_place (value
, args
));
5532 /*_ . Treat quasiquoted vector */
5534 DEF_CFUNC (ps0a1
, kernel_treat_qquoted_vec
, K_ANY
,T_NO_K
)
5537 /* $$IMPROVE ME Include vector applicative directly, not by applying
5538 symbol. This does need to apply, though, so that backquote (now
5539 seeing a list) can be run on "value" first*/
5540 return (mcons (mk_symbol ("apply"),
5541 mcons (mk_symbol ("vector"),
5542 mcons (mcons (sc
->QQUOTE
, mcons (value
, K_NIL
)),
5545 /*_ , Loading files */
5546 /*_ . load_from_port */
5547 /* $$RETHINK ME This soon need no longer be a cfunc */
5548 SIG_CHKARRAY(load_from_port
) = { REF_OPER(is_inport
), REF_OPER(is_environment
)};
5549 DEF_SIMPLE_CFUNC(ps0a2
,load_from_port
,0)
5551 WITH_2_ARGS(inport
,env
);
5552 assert (is_port(inport
));
5553 assert (is_environment(env
));
5554 /* Print that we're loading (If there's an outport, and we may want
5555 to add a verbosity condition based on a dynamic variable) */
5556 pko the_outport
= klink_find_dyn_binding(sc
,K_OUTPORT
);
5557 if(the_outport
&& (the_outport
!= K_NIL
))
5559 port
* pt
= portvalue(inport
);
5560 if(pt
->kind
& port_file
)
5562 const char *fname
= pt
->rep
.stdio
.filename
;
5564 { fname
= "<unknown>"; }
5565 putstr(sc
,"Loading ");
5571 /* We will do the evals in ENV */
5573 klink_push_dyn_binding(sc
,K_INPORT
,inport
);
5574 return kernel_rel(sc
);
5578 SIG_CHKARRAY(k_load_file
) = { REF_OPER(is_string
), };
5579 DEF_SIMPLE_APPLICATIVE(ps0a1
,k_load_file
,0,ground
, "load")
5581 WITH_1_ARGS(filename_ob
);
5582 const char * filename
= string_value(filename_ob
);
5583 pko p
= port_from_filename (filename
, port_file
| port_input
);
5586 KERNEL_ERROR_1(sc
,"unable to open", filename_ob
);
5589 return load_from_port(sc
,p
,sc
->envir
);
5591 /*_ . get-module-from-port */
5592 SIG_CHKARRAY(k_get_mod_fm_port
) =
5593 { REF_OPER(is_port
), REF_KEY(K_TYCH_OPTIONAL
), REF_OPER(is_environment
), };
5594 DEF_SIMPLE_APPLICATIVE(ps0a2
,k_get_mod_fm_port
,0,ground
, "get-module-from-port")
5596 WITH_2_ARGS(port
, params
);
5597 pko env
= mk_std_environment();
5598 if(params
!= K_INERT
)
5600 assert(is_environment(params
));
5601 kernel_define (env
, mk_symbol ("module-parameters"), params
);
5603 /* Ultimately return that environment. */
5604 CONTIN_1R(dcrry_NdotALL
,val2val
,sc
,env
);
5605 return load_from_port(sc
, port
,env
);
5609 /*_ , Writing chars */
5611 putstr (klink
* sc
, const char *s
)
5613 pko the_outport
= klink_find_dyn_binding(sc
,K_OUTPORT
);
5614 port
*pt
= portvalue (the_outport
); /* $$MAKE ME SAFER - check for K_NIL */
5616 if (pt
->kind
& port_file
)
5618 fputs (s
, pt
->rep
.stdio
.file
);
5624 if (pt
->rep
.string
.curr
!= pt
->rep
.string
.past_the_end
)
5626 *pt
->rep
.string
.curr
++ = *s
;
5628 else if (pt
->kind
& port_srfi6
&& realloc_port_string (pt
))
5630 *pt
->rep
.string
.curr
++ = *s
;
5637 putchars (klink
* sc
, const char *s
, int len
)
5639 pko the_outport
= klink_find_dyn_binding(sc
,K_OUTPORT
);
5640 port
*pt
= portvalue (the_outport
); /* $$MAKE ME SAFER - check for K_NIL */
5642 if (pt
->kind
& port_file
)
5644 fwrite (s
, 1, len
, pt
->rep
.stdio
.file
);
5650 if (pt
->rep
.string
.curr
!= pt
->rep
.string
.past_the_end
)
5652 *pt
->rep
.string
.curr
++ = *s
++;
5654 else if (pt
->kind
& port_srfi6
&& realloc_port_string (pt
))
5656 *pt
->rep
.string
.curr
++ = *s
++;
5663 putcharacter (klink
* sc
, int c
)
5665 pko the_outport
= klink_find_dyn_binding(sc
,K_OUTPORT
);
5666 port
*pt
= portvalue (the_outport
); /* $$MAKE ME SAFER - check for K_NIL */
5668 if (pt
->kind
& port_file
)
5670 fputc (c
, pt
->rep
.stdio
.file
);
5674 if (pt
->rep
.string
.curr
!= pt
->rep
.string
.past_the_end
)
5676 *pt
->rep
.string
.curr
++ = c
;
5678 else if (pt
->kind
& port_srfi6
&& realloc_port_string (pt
))
5680 *pt
->rep
.string
.curr
++ = c
;
5685 #define ok_abbrev(x) (is_pair(x) && cdr(x) == K_NIL)
5688 printslashstring (klink
* sc
, char *p
, int len
)
5691 unsigned char *s
= (unsigned char *) p
;
5692 putcharacter (sc
, '"');
5693 for (i
= 0; i
< len
; i
++)
5695 if (*s
== 0xff || *s
== '"' || *s
< ' ' || *s
== '\\')
5697 putcharacter (sc
, '\\');
5701 putcharacter (sc
, '"');
5704 putcharacter (sc
, 'n');
5707 putcharacter (sc
, 't');
5710 putcharacter (sc
, 'r');
5713 putcharacter (sc
, '\\');
5718 putcharacter (sc
, 'x');
5721 putcharacter (sc
, d
+ '0');
5725 putcharacter (sc
, d
- 10 + 'A');
5730 putcharacter (sc
, d
+ '0');
5734 putcharacter (sc
, d
- 10 + 'A');
5741 putcharacter (sc
, *s
);
5745 putcharacter (sc
, '"');
5748 /*_ , Printing atoms */
5750 printatom (klink
* sc
, pko l
)
5754 atom2str (sc
, l
, &p
, &len
);
5755 putchars (sc
, p
, len
);
5759 /* Uses internal buffer unless string pointer is already available */
5761 atom2str (klink
* sc
, pko l
, char **pp
, int *plen
)
5765 pko p_escapes
= klink_find_dyn_binding(sc
,K_PRINT_FLAG
);
5766 int escapes
= (p_escapes
== K_T
) ? 1 : 0;
5780 else if (l
== K_INERT
)
5784 else if (l
== K_IGNORE
)
5788 else if (l
== K_EOF
)
5792 else if (is_port (l
))
5795 snprintf (p
, STRBUFFSIZE
, "#<PORT>");
5797 else if (is_number (l
))
5800 if (num_is_integer (l
))
5802 snprintf (p
, STRBUFFSIZE
, "%ld", ivalue (l
));
5806 snprintf (p
, STRBUFFSIZE
, "%.10g", rvalue (l
));
5809 else if (is_string (l
))
5813 p
= string_value (l
);
5816 { /* Hack, uses the fact that printing is needed */
5819 printslashstring (sc
, string_value (l
), string_len (l
));
5823 else if (is_character (l
))
5825 int c
= charvalue (l
);
5837 snprintf (p
, STRBUFFSIZE
, "#\\space");
5840 snprintf (p
, STRBUFFSIZE
, "#\\newline");
5843 snprintf (p
, STRBUFFSIZE
, "#\\return");
5846 snprintf (p
, STRBUFFSIZE
, "#\\tab");
5852 snprintf (p
, STRBUFFSIZE
, "#\\del");
5857 snprintf (p
, STRBUFFSIZE
, "#\\%s", charnames
[c
]);
5863 snprintf (p
, STRBUFFSIZE
, "#\\x%x", c
);
5868 snprintf (p
, STRBUFFSIZE
, "#\\%c", c
);
5874 else if (is_symbol (l
))
5880 else if (is_environment (l
))
5882 p
= "#<ENVIRONMENT>";
5884 else if (is_continuation (l
))
5886 p
= "#<CONTINUATION>";
5888 else if (is_operative (l
)
5889 /* $$TRANSITIONAL When these can be launched by
5890 themselves, this check will be folded into is_operative */
5891 || is_type (l
, T_DESTRUCTURE
)
5892 || is_type (l
, T_TYPECHECK
)
5893 || is_type (l
, T_TYPEP
))
5895 /* $$TRANSITIONAL This logic will move, probably into
5896 k_print_special_and_balk_p, and become more general. */
5898 print_lookup_unwraps
?
5899 reverse_find_slot_in_env_aux(print_lookup_unwraps
,l
) :
5904 snprintf (p
, STRBUFFSIZE
, ",(unwrap #,%s)", symname(0, car(slot
)));
5909 print_lookup_to_xary
?
5910 reverse_find_slot_in_env_aux(print_lookup_to_xary
,l
) :
5914 /* We don't say it's the tree-ary version, because the
5915 tree-ary conversion is not exposed. */
5916 p
= symname(0, car(slot
));
5922 reverse_find_slot_in_env_aux(all_builtins_env
, l
) :
5926 p
= symname(0, car(slot
));
5929 { p
= "#<OPERATIVE>"; }}
5932 else if (is_promise (l
))
5936 else if (is_applicative (l
))
5938 p
= "#<APPLICATIVE>";
5940 else if (is_type (l
, T_ENCAP
))
5942 p
= "#<ENCAPSULATION>";
5944 else if (is_type (l
, T_KEY
))
5948 else if (is_type (l
, T_RECUR_TRACKER
))
5950 p
= "#<RECURRENCE TRACKER>";
5952 else if (is_type (l
, T_RECURRENCES
))
5954 p
= "#<RECURRENCE TABLE>";
5959 snprintf (p
, STRBUFFSIZE
, "#<ERROR %d>", _get_type(l
));
5965 /*_ , C-style entry points */
5967 /*_ , kernel_print_sexp */
5968 SIG_CHKARRAY(kernel_print_sexp
) =
5969 { K_ANY
, REF_KEY(K_TYCH_OPTIONAL
), REF_OPER(is_environment
), };
5971 DEF_SIMPLE_CFUNC (ps0a2
, kernel_print_sexp
,0)
5973 WITH_2_ARGS(sexp
, lookup_env
);
5974 pko recurrences
= get_recurrences(sc
, sexp
);
5975 pko tracker
= recurrences_to_recur_tracker(recurrences
);
5976 /* $$IMPROVE ME Default to an environment that knows sharp
5978 return kernel_print_sexp_aux
5981 ((lookup_env
== K_INERT
) ? ground_env
: lookup_env
));
5983 /*_ , k_print_special_and_balk_p */
5984 /* Possibly print a replacement or prefix. Return 1 if we should now
5985 skip printing sexp (Because it's shared), 0 otherwise. */
5987 k_print_special_and_balk_p
5988 (klink
* sc
, pko tracker
, pko lookup_env
, pko sexp
)
5991 /* If this object is directly known to printer, print its symbol. */
5992 if(lookup_env
!= K_NIL
)
5994 pko slot
= reverse_find_slot_in_env_aux(lookup_env
,sexp
);
5997 putstr (sc
, "#,"); /* Reader is to convert the symbol */
5998 printatom (sc
, car(slot
));
6002 if(tracker
== K_NIL
)
6005 /* $$IMPROVE ME Parameterize this and share that parameterization
6006 with get_recurrences */
6007 switch(_get_type(sexp
))
6016 WITH_PSYC_UNBOXED(kt_recur_tracker
,tracker
, T_RECUR_TRACKER
, sc
);
6017 int index
= objtable_get_index(pdata
->objs
,pdata
->table_size
,sexp
);
6018 if(index
< 0) { return 0; }
6019 recur_entry
* slot
= &pdata
->entries
[index
];
6020 if(slot
->count
<= 1) { return 0; }
6022 if(slot
->seen_in_walk
)
6024 char *p
= sc
->strbuff
;
6025 snprintf (p
, STRBUFFSIZE
, "#%d", slot
->index_in_walk
);
6026 putchars (sc
, p
, strlen (p
));
6027 return 1; /* Skip printing the object */
6031 slot
->seen_in_walk
= 1;
6032 slot
->index_in_walk
= pdata
->current_index
;
6033 pdata
->current_index
++;
6034 char *p
= sc
->strbuff
;
6035 snprintf (p
, STRBUFFSIZE
, "#%d=", slot
->index_in_walk
);
6036 putchars (sc
, p
, strlen (p
));
6037 return 0; /* Still should print the object */
6040 /*_ , kernel_print_sexp_aux */
6041 SIG_CHKARRAY(kernel_print_sexp_aux
) =
6042 { K_ANY
, REF_OPER(is_recur_tracker
), REF_OPER(is_environment
), };
6044 DEF_SIMPLE_CFUNC (ps0a3
, kernel_print_sexp_aux
,0)
6046 WITH_3_ARGS(sexp
, recur_tracker
, lookup_env
);
6048 if(k_print_special_and_balk_p(sc
, recur_tracker
, lookup_env
, sexp
))
6050 if (is_vector (sexp
))
6053 CONTIN_4 (dcrry_4dotALL
, kernel_print_vec_from
, sc
, sexp
,
6054 mk_integer (0), recur_tracker
, lookup_env
);
6057 else if (!is_pair (sexp
))
6059 printatom (sc
, sexp
);
6062 /* $$FIX ME Recognize quote etc.
6064 That is hard since the quote operative is not currently defined
6065 as such and we no longer have syntax.
6067 else if (car (sexp
) == sc
->QUOTE
&& ok_abbrev (cdr (sexp
)))
6070 return kernel_print_sexp_aux (sc
, cadr (sexp
), recur_tracker
, lookup_env
);
6072 else if (car (sexp
) == sc
->QQUOTE
&& ok_abbrev (cdr (sexp
)))
6075 return kernel_print_sexp_aux (sc
, cadr (sexp
), recur_tracker
, lookup_env
);
6077 else if (car (sexp
) == sc
->UNQUOTE
&& ok_abbrev (cdr (sexp
)))
6080 return kernel_print_sexp_aux (sc
, cadr (sexp
), recur_tracker
, lookup_env
);
6082 else if (car (sexp
) == sc
->UNQUOTESP
&& ok_abbrev (cdr (sexp
)))
6085 return kernel_print_sexp_aux (sc
, cadr (sexp
), recur_tracker
, lookup_env
);
6090 CONTIN_0_RAW(REF_OBJ(k_print_terminate_list
), sc
);
6091 CONTIN_3 (dcrry_2dotALL
, kernel_print_list
, sc
, cdr (sexp
), recur_tracker
, lookup_env
);
6092 return kernel_print_sexp_aux (sc
, car (sexp
), recur_tracker
, lookup_env
);
6095 /*_ , print_value */
6096 DEF_BOXED_CURRIED(print_value
,
6099 REF_OPER (kernel_print_sexp
));
6100 /*_ . k_print_string */
6101 SIG_CHKARRAY(k_print_string
) = { REF_OPER(is_string
), };
6103 DEF_SIMPLE_CFUNC (ps0a1
, k_print_string
,T_NO_K
)
6106 putstr (sc
, string_value(str
));
6109 /*_ . k_print_terminate_list */
6110 /* $$RETHINK ME This may be the long way to do it. */
6112 BOX_OF(kt_string
) _k_string_rpar
=
6113 { T_STRING
| T_IMMUTABLE
,
6114 { ")", sizeof(")"), },
6117 BOX_OF(kt_vec2
) _k_list_string_rpar
=
6118 { T_PAIR
| T_IMMUTABLE
,
6119 { REF_OBJ(_k_string_rpar
), REF_KEY(K_NIL
)}
6122 DEF_BOXED_CURRIED(k_print_terminate_list
,
6124 REF_OBJ(_k_list_string_rpar
),
6125 REF_OPER(k_print_string
));
6127 RGSTR(ground
, "newline", REF_OBJ(k_newline
))
6129 BOX_OF(kt_string
) _k_string_newline
=
6130 { T_STRING
| T_IMMUTABLE
,
6131 { "\n", sizeof("\n"), }, };
6133 BOX_OF(kt_vec2
) _k_list_string_newline
=
6134 { T_PAIR
| T_IMMUTABLE
,
6135 { REF_OBJ(_k_string_newline
), REF_KEY(K_NIL
)}
6138 DEF_BOXED_CURRIED(k_newline
,
6140 REF_OBJ(_k_list_string_newline
),
6141 REF_OPER(k_print_string
));
6143 /*_ . kernel_print_list */
6145 DEF_CFUNC (ps0a3
, kernel_print_list
, REF_DESTR(kernel_print_sexp_aux
),0)
6148 WITH_3_ARGS(sexp
, recur_tracker
, lookup_env
);
6149 if(is_pair (sexp
)) { putstr (sc
, " "); }
6150 else if (sexp
!= K_NIL
) { putstr (sc
, " . "); }
6153 if(k_print_special_and_balk_p(sc
, recur_tracker
, lookup_env
, sexp
))
6157 CONTIN_3 (dcrry_3dotALL
, kernel_print_list
, sc
, cdr (sexp
), recur_tracker
, lookup_env
);
6158 return kernel_print_sexp_aux (sc
, car (sexp
), recur_tracker
, lookup_env
);
6160 if (is_vector (sexp
))
6162 /* $$RETHINK ME What does this even print? */
6163 CONTIN_3 (dcrry_3dotALL
, kernel_print_list
, sc
, K_NIL
, recur_tracker
, lookup_env
);
6164 return kernel_print_sexp_aux (sc
, sexp
, recur_tracker
, lookup_env
);
6169 printatom (sc
, sexp
);
6175 /*_ . kernel_print_vec_from */
6176 SIG_CHKARRAY(kernel_print_vec_from
) =
6178 REF_OPER(is_integer
),
6179 REF_OPER(is_recur_tracker
),
6180 REF_OPER(is_environment
), };
6181 DEF_SIMPLE_CFUNC (ps0a4
, kernel_print_vec_from
,0)
6183 WITH_4_ARGS(vec
,k_i
, recur_tracker
, lookup_env
);
6184 int i
= ivalue (k_i
);
6185 int len
= vector_len (vec
);
6193 pko elem
= vector_elem (vec
, i
);
6194 set_ivalue (k_i
, i
+ 1);
6195 CONTIN_4 (dcrry_4dotALL
, kernel_print_vec_from
, sc
, vec
, arg2
, recur_tracker
, lookup_env
);
6197 return kernel_print_sexp_aux (sc
, elem
, recur_tracker
, lookup_env
);
6200 /*_ , Kernel entry points */
6202 DEF_APPLICATIVE_W_DESTR(ps0a1
,k_write
,K_ANY_SINGLETON
,0,ground
, "write")
6205 klink_push_dyn_binding(sc
,K_PRINT_FLAG
,K_T
);
6206 return kernel_print_sexp(sc
,p
,K_INERT
);
6210 DEF_APPLICATIVE_W_DESTR(ps0a1
,k_display
,K_ANY_SINGLETON
,0,ground
, "display")
6213 klink_push_dyn_binding(sc
,K_PRINT_FLAG
,K_F
);
6214 return kernel_print_sexp(sc
,p
,K_INERT
);
6218 /*_ . tracing_say */
6219 /* $$TRANSITIONAL Until we have actual trace hook */
6220 SIG_CHKARRAY(tracing_say
) = { REF_OPER(is_string
), K_ANY
, };
6221 DEF_SIMPLE_CFUNC (ps0a2
, tracing_say
,T_NO_K
)
6223 WITH_2_ARGS(k_string
, value
);
6226 putstr (sc
, string_value(k_string
));
6232 /*_ . Equivalence */
6233 /*_ , Equivalence of atoms */
6234 SIG_CHKARRAY(eqv
) = { K_ANY
, K_ANY
, };
6235 DEF_SIMPLE_APPLICATIVE(b00a2
,eqv
,T_NO_K
,simple
,"equal?/2-atom-atom")
6243 const char * a_str
= string_value (a
);
6244 const char * b_str
= string_value (b
);
6245 if (a_str
== b_str
) { return 1; }
6246 return !strcmp(a_str
, b_str
);
6251 else if (is_number (a
))
6255 if (num_is_integer (a
) == num_is_integer (b
))
6256 return num_eq (nvalue (a
), nvalue (b
));
6260 else if (is_character (a
))
6262 if (is_character (b
))
6263 return charvalue (a
) == charvalue (b
);
6267 else if (is_port (a
))
6279 /*_ , Equivalence of containers */
6281 /*_ . Hash function */
6282 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
6285 hash_fn (const char *key
, int table_size
)
6287 unsigned int hashed
= 0;
6289 int bits_per_int
= sizeof (unsigned int) * 8;
6291 for (c
= key
; *c
; c
++)
6293 /* letters have about 5 bits in them */
6294 hashed
= (hashed
<< 5) | (hashed
>> (bits_per_int
- 5));
6297 return hashed
% table_size
;
6301 /* Quick and dirty hash function for pointers */
6303 ptr_hash_fn(void * ptr
, int table_size
)
6304 { return (long)ptr
% table_size
; }
6306 /*_ . binder/accessor maker */
6307 pko
make_keyed_variable(pko gen_binder
, pko gen_accessor
)
6309 /* Make a unique key object */
6310 pko key
= mk_void();
6311 pko binder
= wrap (mk_curried
6315 pko accessor
= wrap (mk_curried
6319 /* Curry and wrap the two things. */
6320 return LIST2 (binder
, accessor
);
6323 /*_ . Environment implementation */
6324 /*_ , New-style environment objects */
6328 /* T_ENV_FRAME is a vec2 used as a pair in the env tree. It
6329 indicates a frame boundary.
6331 /* T_ENV_PAIR is another vec2 used as a pair in the env tree. It
6332 indicates no frame boundary.
6335 /* Other types are (hackishly) still shared with the vanilla types:
6337 A vector is interpeted as a hash table vector that is "as if" it
6338 were a list of T_ENV_PAIR. Each element is an alist of bindings.
6339 It can only hold symbol bindings, not keyed bindings, because we
6340 can't hash keyed bindings.
6342 A pair is interpreted as a binding of something and value. That
6343 something can be either a symbol or a key (void object). It is
6344 held directly by an T_ENV_FRAME or T_ENV_PAIR (or "as if", by the
6345 alists of a hash table vector).
6349 /*_ . Object functions */
6351 DEF_T_PRED (is_environment
, T_ENV_FRAME
,ground
,"environment?/o1");
6353 /*_ , New environment implementation */
6355 #ifndef USE_ALIST_ENV
6357 find_slot_in_env_vector (pko eobj
, pko hdl
)
6359 for (; eobj
!= K_NIL
; eobj
= unsafe_v2cdr (eobj
))
6361 assert (is_pair (eobj
));
6362 pko slot
= unsafe_v2car (eobj
);
6363 assert (is_pair (slot
));
6364 if (unsafe_v2car (slot
) == hdl
)
6373 reverse_find_slot_in_env_vector (pko eobj
, pko value
)
6375 for (; eobj
!= K_NIL
; eobj
= unsafe_v2cdr (eobj
))
6377 assert (is_pair (eobj
));
6378 pko slot
= unsafe_v2car (eobj
);
6379 assert (is_pair (slot
));
6380 if (unsafe_v2cdr (slot
) == value
)
6390 * If we're using vectors, each frame of the environment may be a hash
6391 * table: a vector of alists hashed by variable name. In practice, we
6392 * use a vector only for the initial frame; subsequent frames are too
6393 * small and transient for the lookup speed to out-weigh the cost of
6394 * making a new vector.
6397 make_new_frame(pko old_env
)
6400 #ifndef USE_ALIST_ENV
6401 /* $$IMPROVE ME Make a better test for whether to make vector. */
6402 /* The interaction-environment has about 300 variables in it. */
6403 if (old_env
== K_NIL
)
6405 new_frame
= mk_vector (461, K_NIL
);
6413 return v2cons (T_ENV_FRAME
, new_frame
, old_env
);
6417 new_slot_spec_in_env (pko env
, pko variable
, pko value
)
6419 assert(is_environment(env
));
6420 assert(is_symbol(variable
));
6421 pko slot
= mcons (variable
, value
);
6422 pko car_env
= unsafe_v2car (env
);
6423 #ifndef USE_ALIST_ENV
6424 if (is_vector (car_env
))
6426 int location
= hash_fn (symname (0,variable
), vector_len (car_env
));
6428 set_vector_elem (car_env
, location
,
6430 vector_elem (car_env
, location
)));
6435 pko new_list
= v2cons (T_ENV_PAIR
, slot
, car_env
);
6436 unsafe_v2set_car (env
, new_list
);
6440 enum env_frame_search_restriction
6443 env_fsr_only_coming_frame
,
6444 env_fsr_only_this_frame
,
6447 /* This explores a tree of bindings, punctuated by frames past which
6448 we sometimes don't search. */
6450 find_slot_in_env_aux (pko eobj
, pko hdl
, int restr
)
6454 _kt_tag type
= _get_type (eobj
);
6457 /* We have a slot (Which for now is just a pair) */
6459 if(unsafe_v2car (eobj
) == hdl
)
6463 #ifndef USE_ALIST_ENV
6466 /* Only for symbols. */
6467 if(!is_symbol (hdl
)) { return 0; }
6468 int location
= hash_fn (symname (0,hdl
), vector_len (eobj
));
6469 pko el
= vector_elem (eobj
, location
);
6470 return find_slot_in_env_vector (el
, hdl
);
6473 /* We have some sort of env pair */
6475 /* Check whether we should keep looking. */
6480 case env_fsr_only_coming_frame
:
6481 restr
= env_fsr_only_this_frame
;
6483 case env_fsr_only_this_frame
:
6487 "find_slot_in_env_aux: Bad restriction enum: %d", restr
);
6492 /* Explore car before cdr */
6493 pko found
= find_slot_in_env_aux (unsafe_v2car (eobj
), hdl
, restr
);
6494 if(found
) { return found
; }
6495 return find_slot_in_env_aux (unsafe_v2cdr (eobj
),hdl
,restr
);
6498 /* No other type should be found */
6500 "find_slot_in_env_aux: Bad type: %d", type
);
6501 return 0; /* NOTREACHED */
6506 find_slot_in_env (pko env
, pko hdl
, int all
)
6508 assert(is_environment(env
));
6509 enum env_frame_search_restriction restr
=
6510 all
? env_fsr_all
: env_fsr_only_coming_frame
;
6511 return find_slot_in_env_aux(env
,hdl
,restr
);
6513 /*_ , Reverse find-slot */
6514 /*_ . env_confirm_slot */
6516 env_confirm_slot(pko env
, pko slot
)
6518 assert(is_pair(slot
));
6520 (find_slot_in_env_aux(env
,unsafe_v2car(slot
),env_fsr_all
) == slot
);
6522 /*_ . reverse_find_slot_in_env_aux2 */
6524 reverse_find_slot_in_env_aux2(pko env
, pko eobj
, pko value
)
6528 _kt_tag type
= _get_type (eobj
);
6531 /* We have a slot (Which for now is just a pair) */
6533 if((unsafe_v2cdr (eobj
) == value
)
6534 && env_confirm_slot(env
, eobj
))
6538 #ifndef USE_ALIST_ENV
6541 /* $$IMPROVE ME Create a reverse-lookup vector if we come here
6542 and there is none. */
6544 for(i
= 0; i
< vector_len (eobj
); ++i
)
6546 pko slot
= reverse_find_slot_in_env_vector(vector_elem (eobj
, i
), value
);
6548 env_confirm_slot(env
, slot
))
6554 /* We have some sort of env pair */
6559 /* Explore car before cdr */
6561 reverse_find_slot_in_env_aux2 (env
, unsafe_v2car (eobj
), value
);
6562 if(found
&& env_confirm_slot(env
, found
))
6565 reverse_find_slot_in_env_aux2 (env
, unsafe_v2cdr (eobj
), value
);
6566 if(found
&& env_confirm_slot(env
, found
))
6571 /* No other type should be found */
6573 "reverse_find_slot_in_env_aux2: Bad type: %d", type
);
6574 return 0; /* NOTREACHED */
6578 /*_ . reverse_find_slot_in_env_aux */
6580 reverse_find_slot_in_env_aux (pko env
, pko value
)
6582 assert(is_environment(env
));
6583 return reverse_find_slot_in_env_aux2(env
, env
, value
);
6586 /*_ . Entry point */
6587 /* Exposed for testing */
6588 /* NB, args are in different order than in the helpers */
6589 SIG_CHKARRAY(reverse_find_slot_in_env
) =
6590 { K_ANY
, REF_OPER(is_environment
), };
6591 DEF_SIMPLE_APPLICATIVE (ps0a2
, reverse_find_slot_in_env
,T_NO_K
,unsafe
, "reverse-lookup")
6593 WITH_2_ARGS(value
,env
);
6595 pko slot
= reverse_find_slot_in_env_aux(env
, value
);
6596 if(slot
) { return car(slot
); }
6599 KERNEL_ERROR_0(sc
, "reverse_find_slot_in_env: No match");
6603 /*_ . reverse-binds?/2 */
6604 /* $$IMPROVE ME Maybe combine these */
6605 DEF_APPLICATIVE_W_DESTR(b00a2
,reverse_binds_p
,
6606 REF_DESTR(reverse_find_slot_in_env
),
6607 T_NO_K
,simple
,"reverse-binds?/2")
6609 WITH_2_ARGS(value
,env
);
6610 return reverse_find_slot_in_env_aux(env
, value
) ? 1 : 0;
6612 /*_ , Shared functions */
6615 new_frame_in_env (klink
* sc
, pko old_env
)
6617 sc
->envir
= make_new_frame (old_env
);
6621 set_slot_in_env (pko slot
, pko value
)
6623 assert (is_pair (slot
));
6624 set_cdr (0, slot
, value
);
6628 slot_value_in_env (pko slot
)
6631 assert (is_pair (slot
));
6635 /*_ , Keyed static bindings */
6637 /*_ , Making them */
6638 /* Make a new frame containing just the one keyed static variable. */
6640 env_plus_keyed_var (pko key
, pko value
, pko old_env
)
6642 pko slot
= cons (key
, value
);
6643 return v2cons (T_ENV_FRAME
, slot
, old_env
);
6645 /*_ , Finding them */
6646 /* find_slot_in_env works for this too. */
6649 SIG_CHKARRAY(klink_ksb_binder
) =
6650 { REF_OPER(is_key
), K_ANY
, REF_OPER(is_environment
), };
6651 DEF_SIMPLE_CFUNC(ps0a3
,klink_ksb_binder
,T_NO_K
)
6653 WITH_3_ARGS(key
, value
, env
);
6654 /* Check that env is in fact a environment. */
6655 if(!is_environment(env
))
6658 "klink_ksb_binder: Arg 2 must be an environment: ",
6661 /* Return a new environment with just that binding. */
6662 return env_plus_keyed_var(key
, value
, env
);
6666 SIG_CHKARRAY(klink_ksb_accessor
) =
6667 { REF_OPER(is_key
), };
6668 DEF_SIMPLE_CFUNC(ps0a1
,klink_ksb_accessor
,T_NO_K
)
6671 pko value
= find_slot_in_env(sc
->envir
,key
,1);
6674 KERNEL_ERROR_0(sc
, "klink_ksb_accessor: No binding found");
6677 return slot_value_in_env (value
);
6680 /*_ , make_keyed_static_variable */
6681 RGSTR(ground
, "make-keyed-static-variable", REF_OPER(make_keyed_static_variable
))
6682 DEF_CFUNC(p00a0
, make_keyed_static_variable
,K_NO_TYPE
,T_NO_K
)
6684 return make_keyed_variable(
6685 REF_OPER(klink_ksb_binder
),
6686 REF_OPER (klink_ksb_accessor
));
6688 /*_ , Building environments */
6689 /* Argobject is checked internally, so K_ANY */
6690 DEF_APPLICATIVE_W_DESTR(ps0a1
,make_environment
,K_ANY
,T_NO_K
,ground
, "make-environment")
6692 WITH_1_ARGS(parents
);
6693 /* $$IMPROVE ME Factor this so we only call get_list_metrics_aux
6694 once on this object. */
6696 get_list_metrics_aux(parents
, metrics
);
6697 pko typecheck
= REF_OPER(is_environment
);
6698 /* This will reject dotted lists */
6699 if(!typecheck_repeat(sc
,parents
,&typecheck
,1,1))
6701 KERNEL_ERROR_0 (sc
, "make_environment: argobject must be a list of environments");
6704 /* Collect the parent environments. */
6706 pko rv_par_list
= K_NIL
;
6707 for(i
= 0; i
< metrics
[lm_num_pairs
]; ++i
, parents
= pair_cdr(0, parents
))
6709 pko pare
= pair_car(0, parents
);
6710 rv_par_list
= v2cons (T_ENV_PAIR
, pare
, rv_par_list
);
6713 /* Reverse the list in place. */
6716 par_list
= unsafe_v2reverse_in_place(K_NIL
, rv_par_list
);
6718 /* $$IMPROVE ME Check for redundant environments and skip them.
6719 Check only *previous* environments, because we still need to
6720 search correctly. When recurrences walks environments too, we
6721 can use that to find them. */
6722 /* $$IMPROVE ME Add to environment information to block rechecks. */
6724 /* Return a new environment with all of those as parents. */
6725 return make_new_frame(par_list
);
6728 RGSTR(simple
,"$binds?/2", REF_OPER(bindsp_1
))
6729 SIG_CHKARRAY(bindsp_1
) =
6730 { REF_OPER(is_environment
), REF_OPER(is_symbol
), };
6731 DEF_SIMPLE_CFUNC(bs0a2
,bindsp_1
,T_NO_K
)
6733 WITH_2_ARGS(env
, sym
);
6734 return find_slot_in_env(env
, sym
, 1) ? 1 : 0;
6736 /*_ , find-binding */
6737 DEF_APPLICATIVE_W_DESTR(ps0a2
,find_binding
,REF_DESTR(bindsp_1
),T_NO_K
,ground
,"find-binding")
6739 WITH_2_ARGS(env
, sym
);
6740 pko binding
= find_slot_in_env(env
, sym
, 1);
6743 return cons(K_T
,slot_value_in_env (binding
));
6747 return cons(K_F
,K_INERT
);
6752 /*_ , Enumerations */
6753 enum klink_stack_cell_types
6762 ksct_arg_barrier
, /* Barrier to propagating pseudo-env. */
6766 struct dump_stack_frame
6771 struct stack_binding
6783 struct stack_profiling
6796 typedef struct dump_stack_frame_cell
6798 enum klink_stack_cell_types type
;
6802 struct dump_stack_frame frame
;
6803 struct stack_binding binding
;
6804 struct stack_guards guards
;
6805 struct stack_profiling profiling
;
6806 struct stack_arg pseudoenv
;
6808 } dump_stack_frame_cell
;
6813 dump_stack_initialize (klink
* sc
)
6819 stack_empty (klink
* sc
)
6820 { return sc
->dump
== 0; }
6824 klink_pop_cont (klink
* sc
)
6826 _kt_spagstack rv_pseudoenvs
= 0;
6828 /* Always return frame, which sc->dump will be set to. */
6829 /* for(frame = sc->dump; frame != 0; frame = frame->next) */
6838 const _kt_spagstack frame
= sc
->dump
;
6839 if(frame
->type
== ksct_frame
)
6841 const struct dump_stack_frame
*pdata
= &frame
->data
.frame
;
6842 sc
->next_func
= pdata
->ff
;
6843 sc
->envir
= pdata
->envir
;
6845 _kt_spagstack final_frame
= frame
->next
;
6847 /* Add the collected pseudo-env elements */
6848 while(rv_pseudoenvs
)
6850 _kt_spagstack el
= rv_pseudoenvs
;
6851 _kt_spagstack new_top
= rv_pseudoenvs
->next
;
6852 el
->next
= final_frame
;
6854 rv_pseudoenvs
= new_top
;
6856 sc
->dump
= final_frame
;
6861 if(frame
->type
== ksct_profile
)
6863 struct stack_profiling
* pdata
= &frame
->data
.profiling
;
6864 k_profiling_done_frame(sc
,pdata
);
6865 sc
->dump
= frame
->next
;
6868 else if( frame
->type
== ksct_args
)
6870 struct stack_arg
* old_pe
= &frame
->data
.pseudoenv
;
6871 if(old_pe
->frame_depth
> 0)
6873 /* Make a copy, to be re-added lower down */
6874 _kt_spagstack new_pseudoenv
=
6876 GC_MALLOC (sizeof (dump_stack_frame_cell
));
6877 struct stack_arg
* new_pe
= &new_pseudoenv
->data
.pseudoenv
;
6878 new_pe
->vec
= old_pe
->vec
;
6879 new_pe
->frame_depth
= old_pe
->frame_depth
- 1;
6881 new_pseudoenv
->type
= ksct_args
;
6882 new_pseudoenv
->next
= rv_pseudoenvs
;
6883 rv_pseudoenvs
= new_pseudoenv
;
6886 sc
->dump
= frame
->next
;
6888 else if( frame
->type
== ksct_arg_barrier
)
6890 errx( 0, "Not allowed");
6892 sc
->dump
= frame
->next
;
6896 sc
->dump
= frame
->next
;
6902 static _kt_spagstack
6904 (_kt_spagstack old_frame
, pko ff
, pko env
)
6906 _kt_spagstack frame
=
6908 GC_MALLOC (sizeof (dump_stack_frame_cell
));
6909 struct dump_stack_frame
* pdata
= &frame
->data
.frame
;
6913 frame
->type
= ksct_frame
;
6914 frame
->next
= old_frame
;
6920 klink_push_cont (klink
* sc
, pko ff
)
6921 { sc
->dump
= klink_push_cont_aux(sc
->dump
, ff
, sc
->envir
); }
6923 /*_ , Dynamic bindings */
6925 /* We do not pop dynamic bindings, only frames. */
6926 /* We deal with dynamic bindings in the context of the interpreter so
6927 that in the future we can cache them. */
6929 klink_push_dyn_binding (klink
* sc
, pko key
, pko value
)
6931 _kt_spagstack frame
=
6933 GC_MALLOC (sizeof (dump_stack_frame_cell
));
6934 struct stack_binding
*pdata
= &frame
->data
.binding
;
6937 pdata
->value
= value
;
6939 frame
->type
= ksct_binding
;
6940 frame
->next
= sc
->dump
;
6946 klink_find_dyn_binding(klink
* sc
, pko key
)
6948 _kt_spagstack frame
= sc
->dump
;
6957 if(frame
->type
== ksct_binding
)
6959 const struct stack_binding
*pdata
= &frame
->data
.binding
;
6960 if(pdata
->key
== key
)
6961 { return pdata
->value
; }
6963 frame
= frame
->next
;
6968 /*_ . klink_push_guards */
6969 static _kt_spagstack
6971 (_kt_spagstack old_frame
, pko guards
, pko envir
, int exit
)
6973 _kt_spagstack frame
=
6975 GC_MALLOC (sizeof (dump_stack_frame_cell
));
6976 struct stack_guards
* pdata
= &frame
->data
.guards
;
6977 pdata
->guards
= guards
;
6978 pdata
->envir
= envir
;
6980 frame
->type
= exit
? ksct_exit_guards
: ksct_entry_guards
;
6981 frame
->next
= old_frame
;
6984 /*_ . get_guards_lo1st */
6985 /* Get a list of guard entries, root-most on top. */
6987 get_guards_lo1st(_kt_spagstack frame
)
6990 for(; frame
!= 0; frame
= frame
->next
)
6992 if((frame
->type
== ksct_entry_guards
) ||
6993 (frame
->type
== ksct_exit_guards
))
6995 list
= cons(mk_continuation(frame
), list
);
7003 /*_ , set_nth_arg */
7005 /* Set the nth arg */
7006 /* Unused, probably for a while, probably will never be used in this
7009 set_nth_arg(klink
* sc
, int n
, pko value
)
7011 _kt_spagstack frame
= sc
->dump
;
7013 for(frame
= sc
->dump
; frame
!= 0; frame
= frame
->next
)
7015 if(frame
->type
== ksct_args
)
7019 frame
->data
.arg
= value
;
7026 /* If we got here we never encountered the target. */
7030 /*_ . Store from value */
7031 /*_ , push_arg_raw */
7033 push_arg_raw(_kt_spagstack old_frame
, pko value
, int frame_depth
)
7035 _kt_spagstack frame
=
7037 GC_MALLOC (sizeof (dump_stack_frame_cell
));
7039 frame
->data
.pseudoenv
.vec
= value
;
7040 frame
->data
.pseudoenv
.frame_depth
= frame_depth
;
7041 frame
->type
= ksct_args
;
7042 frame
->next
= old_frame
;
7048 k_do_store(klink
* sc
, pko functor
, pko value
)
7050 WITH_PSYC_UNBOXED( kt_opstore
, functor
, T_STORE
, sc
);
7051 /* $$MAKE ME SAFE do_destructure must be safe vs resuming. Error if
7052 not T_NO_K. Don't try to maybe resume, because so far we never
7055 pko vec
= do_destructure( sc
, value
, pdata
->destr
);
7056 /* Push that as arg */
7057 sc
->dump
= push_arg_raw (sc
->dump
, vec
, pdata
->frame_depth
);
7060 /*_ . Load to value */
7061 /*_ , get_nth_arg */
7063 get_nth_arg( _kt_spagstack frame
, int n
)
7066 for(; frame
!= 0; frame
= frame
->next
)
7068 if(frame
->type
== ksct_args
)
7071 { return frame
->data
.pseudoenv
.vec
; }
7076 /* If we got here we never encountered the target. */
7080 /*_ , k_load_recurse */
7081 /* $$IMPROVE ME Add a shortcut for accessing value without ever
7084 k_load_recurse( _kt_spagstack frame
, pko tree
)
7086 if(_get_type( tree
) == T_PAIR
)
7088 WITH_PSYC_UNBOXED( kt_vec2
, tree
, T_PAIR
, 0 );
7089 if( is_integer( pdata
->_car
) && is_integer( pdata
->_cdr
))
7091 /* Pair of integers: Look up that item, look up secondary
7093 const int n
= ivalue( pdata
->_car
);
7094 const int m
= ivalue( pdata
->_cdr
);
7095 pko vec
= get_nth_arg( frame
, n
);
7097 assert( is_vector( vec
));
7098 pko value
= basvector_elem( vec
, m
);
7104 /* Pair, not integers: Explore car and cdr, return cons of them. */
7106 k_load_recurse( frame
, pdata
->_car
),
7107 k_load_recurse( frame
, pdata
->_cdr
));
7112 /* Anything else: Return it literally. */
7118 /* T_LOAD C-destructures as a singleton. It will contain a tree */
7119 /* This may largely take over for decurriers. */
7121 k_do_load(klink
* sc
, pko functor
, pko value
)
7123 WITH_PSYC_UNBOXED( pko
, functor
, T_LOAD
, sc
);
7124 return k_load_recurse( sc
->dump
, *pdata
);
7127 /*_ , Stack ancestry */
7128 /*_ . frame_is_ancestor_of */
7129 int frame_is_ancestor_of(_kt_spagstack frame
, _kt_spagstack other
)
7131 /* Walk from other towards root. Return 1 if we ever encounter
7132 frame, otherwise 0. */
7133 for(; other
!= 0; other
= other
->next
)
7140 /*_ . special_dynxtnt */
7141 /* Make a child of dynamic extent OUTER that evals with dynamic
7142 environment ENVIR continues normally to PROX_DEST. */
7143 _kt_spagstack special_dynxtnt
7144 (_kt_spagstack outer
, _kt_spagstack prox_dest
, pko envir
)
7147 klink_push_cont_aux(outer
,
7148 mk_curried(dcrry_2A01VLL
,
7149 LIST1(mk_continuation(prox_dest
)),
7150 REF_OPER(invoke_continuation
)),
7153 /*_ . curr_frame_depth */
7154 int curr_frame_depth(_kt_spagstack frame
)
7156 /* Walk towards root, counting. */
7158 for(; frame
!= 0; frame
= frame
->next
, count
++)
7162 /*_ , Continuations */
7166 _kt_spagstack frame
;
7171 DEF_T_PRED (is_continuation
, T_CONTINUATION
,ground
, "continuation?/o1");
7174 mk_continuation (_kt_spagstack frame
)
7176 ALLOC_BOX_PRESUME (continuation_t
, T_CONTINUATION
);
7177 pdata
->frame
= frame
;
7178 return PTR2PKO(pbox
);
7181 static _kt_spagstack
7184 WITH_PSYC_UNBOXED(continuation_t
,p
,T_CONTINUATION
,0);
7185 return pdata
->frame
;
7188 /*_ . Continuations WRT interpreter */
7189 /*_ , current_continuation */
7191 current_continuation (klink
* sc
)
7193 return mk_continuation (sc
->dump
);
7196 /*_ , invoke_continuation */
7197 /* DOES NOT RETURN */
7198 /* Control is resumed at _klink_cycle */
7200 /* Static and not directly available to Kernel, it's the eventual
7201 target of continuation_to_applicative. */
7202 SIG_CHKARRAY(invoke_continuation
) =
7203 { REF_OPER(is_continuation
), K_ANY
, };
7204 DEF_SIMPLE_CFUNC(vs0a2
,invoke_continuation
,T_NO_K
)
7206 WITH_2_ARGS (p
, value
);
7207 assert(is_continuation(p
));
7209 { sc
->dump
= cont_dump (p
); }
7211 longjmp (sc
->pseudocontinuation
, 1);
7214 /* Add the appropriate guard, if any, and return the new proximate
7218 (_kt_spagstack prox_dest
, _kt_spagstack to_contain
,
7219 pko guard_list
, pko envir
, _kt_spagstack outer
)
7223 for(x
= guard_list
; x
!= K_NIL
; x
= cdr(x
))
7225 pko selector
= car(car(x
));
7226 assert(is_continuation(selector
));
7227 if(frame_is_ancestor_of(cont_dump(selector
), to_contain
))
7229 /* Call has to take place in the dynamic extent of the
7230 next frame around this set of guards, so that the
7231 interceptor has access to dynamic bindings, but then
7232 control has to continue normally to the next guard or
7233 finally to the destination.
7235 So we extend the next frame with a call to
7236 invoke_continuation, currying the next destination in the
7237 chain. That does not check guards, so in effect it
7238 continues normally. Then we extend that with a call to
7239 the interceptor, currying an continuation->applicative of
7240 the guards' outer continuation.
7242 NB, continuation->applicative is correct. It would be
7243 wrong to shortcircuit it. Although there are no guards
7244 between there and the outer continuation, the
7245 continuation we pass might be called from another dynamic
7246 context. But it needs to be unwrapped.
7248 pko wrapped_interceptor
= cadr(car(x
));
7249 assert(is_applicative(wrapped_interceptor
));
7250 pko interceptor
= unwrap(0,wrapped_interceptor
);
7251 assert(is_operative(interceptor
));
7253 _kt_spagstack med_frame
=
7254 special_dynxtnt(outer
, prox_dest
, envir
);
7256 klink_push_cont_aux(med_frame
,
7257 mk_curried(dcrry_2VLLdotALL
,
7258 LIST1(continuation_to_applicative(mk_continuation(outer
))),
7262 /* We use only the first match so end the loop. */
7268 /*_ , add_guard_chain */
7271 (_kt_spagstack prox_dest
, pko guard_frame_list
, _kt_spagstack to_contain
, int exit
)
7274 const enum klink_stack_cell_types tag
7275 = exit
? ksct_exit_guards
: ksct_entry_guards
;
7276 for( ; guard_frame_list
!= K_NIL
; guard_frame_list
= cdr(guard_frame_list
))
7278 _kt_spagstack guard_frame
= cont_dump(car(guard_frame_list
));
7279 if(guard_frame
->type
== tag
)
7281 struct stack_guards
* pguards
= &guard_frame
->data
.guards
;
7283 add_guard(prox_dest
,
7287 exit
? guard_frame
->next
: guard_frame
);
7292 /*_ , continue_abnormally */
7293 /*** Arrange to "walk" from current continuation to c, passing control
7294 thru appropriate guards. ***/
7295 SIG_CHKARRAY(continue_abnormally
) =
7296 { REF_OPER(is_continuation
), K_ANY
, };
7297 /* I don't give this T_NO_K even though technically it longjmps
7298 rather than pushing into the eval loop. In the future we may
7299 distinguish those two cases. */
7300 DEF_SIMPLE_CFUNC(ps0a2
,continue_abnormally
,0)
7302 WITH_2_ARGS(c
,value
);
7304 _kt_spagstack source
= sc
->dump
;
7305 _kt_spagstack destination
= cont_dump (c
);
7307 /*** Find the guard frames on the intermediate path. ***/
7309 /* Control is exiting our current frame, so collect guards from
7310 there towards root. What we get is lowest first. */
7311 pko exiting_lo1st
= get_guards_lo1st(source
);
7312 /* Control is entering c's frame, so collect guards from there
7313 towards root. Again it's lowest first. */
7314 pko entering_lo1st
= get_guards_lo1st(destination
);
7316 /* Remove identical entries from the top, thus removing any merged
7318 while((exiting_lo1st
!= K_NIL
) &&
7319 (entering_lo1st
!= K_NIL
) &&
7320 (cont_dump(car(exiting_lo1st
)) == cont_dump(car(entering_lo1st
))))
7322 exiting_lo1st
= cdr(exiting_lo1st
);
7323 entering_lo1st
= cdr(entering_lo1st
);
7328 /*** Construct a string of calls to the appropriate guards, ending
7329 at destination. We collect in the reverse of the order that
7330 they will be run, so collect from "entering" first, from
7331 highest to lowest, then collect from "exiting", from lowest to
7334 _kt_spagstack prox_dest
= destination
;
7336 pko entering_hi1st
= reverse(sc
, entering_lo1st
);
7337 prox_dest
= add_guard_chain(prox_dest
, entering_hi1st
, destination
, 0);
7338 prox_dest
= add_guard_chain(prox_dest
, exiting_lo1st
, source
, 1);
7340 invoke_continuation(sc
, mk_continuation(prox_dest
), value
);
7341 return value
; /* NOTREACHED */
7346 SIG_CHKARRAY(call_cc
) = { REF_OPER(is_combiner
), };
7347 DEF_SIMPLE_APPLICATIVE(ps0a1
,call_cc
,0,ground
, "call/cc")
7349 WITH_1_ARGS(combiner
);
7350 pko cc
= current_continuation(sc
);
7351 return kernel_eval_aux(sc
,combiner
,LIST1(cc
),sc
->envir
);
7353 /*_ , extend-continuation */
7354 /*_ . extend_continuation_aux */
7356 extend_continuation_aux(_kt_spagstack old_frame
, pko a
, pko env
)
7358 _kt_spagstack frame
= klink_push_cont_aux(old_frame
, a
, env
);
7359 return mk_continuation(frame
);
7361 /*_ . extend_continuation */
7362 SIG_CHKARRAY(extend_continuation
) =
7363 { REF_OPER(is_continuation
),
7364 REF_OPER(is_applicative
),
7365 REF_KEY(K_TYCH_OPTIONAL
),
7366 REF_OPER(is_environment
),
7368 DEF_SIMPLE_APPLICATIVE(ps0a3
, extend_continuation
,T_NO_K
,ground
, "extend-continuation")
7370 WITH_3_ARGS(c
, a
, env
);
7371 assert(is_applicative(a
));
7372 if(env
== K_INERT
) { env
= make_new_frame(K_NIL
); }
7373 return extend_continuation_aux(cont_dump(c
), unwrap(sc
,a
), env
);
7375 /*_ , continuation->applicative */
7376 SIG_CHKARRAY(continuation_to_applicative
) = { REF_OPER(is_continuation
), };
7377 DEF_SIMPLE_APPLICATIVE(p00a1
,continuation_to_applicative
,T_NO_K
,ground
, "continuation->applicative")
7381 wrap(mk_curried (dcrry_2A01VLL
, LIST1(c
), REF_OPER(continue_abnormally
)));
7384 /*_ , guard-continuation */
7385 /* Each guard list is repeat (list continuation applicative) */
7386 /* We'd like to spec that applicative take 2 args, a continuation and
7387 a value, and be wrapped exactly once. */
7388 SIG_CHKARRAY(guard_continuation
) =
7389 { K_ANY
, REF_OPER(is_continuation
), K_ANY
, };
7390 DEF_SIMPLE_APPLICATIVE(ps0a3
,guard_continuation
,T_NO_K
,ground
, "guard-continuation")
7392 WITH_3_ARGS(entry_guards
, c
, exit_guards
);
7393 /* The spec wants an outer continuation to keeps sets of guards from
7394 being mixed together if there are two calls to guard_continuation
7395 with the same c. But that happens naturally here, so it seems
7398 /* $$IMPROVE ME Copy the es of both lists of guards. */
7399 _kt_spagstack frame
= cont_dump(c
);
7400 if(entry_guards
!= K_NIL
)
7402 frame
= klink_push_guards(frame
, entry_guards
, sc
->envir
, 0);
7404 if(exit_guards
!= K_NIL
)
7406 frame
= klink_push_guards(frame
, exit_guards
, sc
->envir
, 1);
7409 pko inner_cont
= mk_continuation(frame
);
7413 /*_ , guard-dynamic-extent */
7414 SIG_CHKARRAY(guard_dynamic_extent
) =
7416 REF_OPER(is_finite_list
),
7417 REF_OPER(is_applicative
),
7418 REF_OPER(is_finite_list
),
7420 /* DOES NOT RETURN */
7421 DEF_SIMPLE_APPLICATIVE(ps0a3
,guard_dynamic_extent
,0,ground
, "guard-dynamic-extent")
7423 WITH_3_ARGS(entry
,app
,exit
);
7424 pko cont
= guard_continuation(sc
,entry
,current_continuation(sc
),exit
);
7425 pko cont2
= extend_continuation(sc
,cont
, app
, sc
->envir
);
7426 /* Skip directly into the new continuation, don't invoke the
7428 invoke_continuation(sc
,cont2
, K_NIL
);
7433 /*_ , Keyed dynamic bindings */
7434 /*_ . klink_kdb_binder */
7435 SIG_CHKARRAY(klink_kdb_binder
) =
7436 { REF_OPER(is_key
), K_ANY
, REF_OPER(is_combiner
), };
7437 DEF_SIMPLE_CFUNC(ps0a3
,klink_kdb_binder
,T_NO_K
)
7439 WITH_3_ARGS(key
, value
, combiner
);
7440 /* Check that combiner is in fact a combiner. */
7441 if(!is_combiner(combiner
))
7444 "klink_kdb_binder: Arg 2 must be a combiner: ",
7447 /* Push the new binding. */
7448 klink_push_dyn_binding(sc
, key
, value
);
7449 /* $$IMPROVE ME In general, should can control calling better than
7450 this. Possibly do this thru invoke_continuation, except we're
7451 not arbitrarily changing continuations. */
7452 /* $$IMPROVE ME Want a better way to control what environment to
7453 push in. In fact, that's much like a dynamic variable. */
7454 /* $$IMPROVE ME Want a better and cheaper way to make empty
7455 environments. The vector thing should be controlled by a hint. */
7456 /* Make an empty static environment */
7457 new_frame_in_env(sc
,K_NIL
);
7458 /* Push combiner in that environment. */
7459 klink_push_cont(sc
,combiner
);
7460 /* And call it with no operands. */
7463 /* Combines with data to become "an applicative that takes two
7464 arguments, the second of which must be a oper. It calls its
7465 second argument with no operands (nil operand tree) in a fresh empty
7466 environment, and returns the result." */
7467 /*_ . klink_kdb_accessor */
7468 SIG_CHKARRAY(klink_kdb_accessor
) =
7469 { REF_OPER(is_key
), };
7470 DEF_SIMPLE_CFUNC(ps0a1
,klink_kdb_accessor
,T_NO_K
)
7473 pko value
= klink_find_dyn_binding(sc
,key
);
7476 KERNEL_ERROR_0(sc
, "klink_kdb_accessor: No binding found");
7480 /* Combines with data to become "an applicative that takes zero
7481 arguments. If the call to a occurs within the dynamic extent of a
7482 call to b, then a returns the value of the first argument passed to
7483 b in the smallest enclosing dynamic extent of a call to b. If the
7484 call to a is not within the dynamic extent of any call to b, an
7487 /*_ . make_keyed_dynamic_variable */
7488 RGSTR(ground
, "make-keyed-dynamic-variable", REF_OPER(make_keyed_dynamic_variable
))
7490 DEF_CFUNC(p00a0
, make_keyed_dynamic_variable
,K_NO_TYPE
,T_NO_K
)
7492 return make_keyed_variable(
7493 REF_OPER(klink_kdb_binder
),
7494 REF_OPER (klink_kdb_accessor
));
7499 typedef struct profiling_data
7507 profiling_data
* entries
;
7511 /*_ . Current data */
7512 /* This may be moved to per interpreter, or even more fine-grained. */
7513 /* This may not always be the way we get elapsed counts. */
7514 static long k_profiling_count
= 0;
7515 static int k_profiling_p
= 0; /* Are we profiling now? */
7516 /* If we are profiling, init this if it's not initted */
7517 static kt_profile_table k_profiling_table
= { 0 };
7518 /*_ . Dealing with table (All will be shared with other lookup tables) */
7521 init_profile_table(kt_profile_table
* p_table
, int initial_size
)
7523 p_table
->objs
= initial_size
?
7524 GC_MALLOC(sizeof(pko
) * initial_size
) : 0;
7525 p_table
->entries
= initial_size
?
7526 GC_MALLOC(sizeof(profiling_data
) * initial_size
) : 0;
7527 p_table
->alloced_size
= initial_size
;
7528 p_table
->table_size
= 0;
7530 /*_ , Increase its size */
7532 enlarge_profile_table(kt_profile_table
* p_table
)
7534 if(p_table
->table_size
== p_table
->alloced_size
)
7536 p_table
->alloced_size
*= 2;
7537 p_table
->entries
= GC_REALLOC(p_table
->entries
, sizeof(profiling_data
) * p_table
->alloced_size
);
7538 p_table
->objs
= GC_REALLOC(p_table
->objs
, sizeof(pko
) * p_table
->alloced_size
);
7543 /*_ , Searching in it */
7544 /* Use objtable_get_index */
7545 /*_ . On the stack */
7546 static struct stack_profiling
*
7547 klink_find_profile_in_frame (_kt_spagstack frame
, pko ff
)
7550 (frame
!= 0) && (frame
->type
!= ksct_frame
) ;
7551 frame
= frame
->next
)
7553 if(frame
->type
== ksct_profile
)
7555 struct stack_profiling
*pdata
= &frame
->data
.profiling
;
7556 if(pdata
->ff
== ff
) { return pdata
; }
7561 /*_ . Profile collection operations */
7562 /*_ , When eval loop steps */
7564 k_profiling_step(void)
7565 { k_profiling_count
++; }
7566 /*_ , When we begin executing a frame */
7567 /* Push a stack_profiling cell onto the frame. */
7570 k_profiling_new_frame(klink
* sc
, pko ff
)
7572 if(!k_profiling_p
) { return; }
7573 if(!is_operative(ff
)) { return; }
7574 /* Do this only if ff is interesting (which for the moment means
7575 that it can be found in ground environment). */
7576 if(!reverse_binds_p(ff
, ground_env
) &&
7577 !reverse_binds_p(ff
, print_lookup_unwraps
) &&
7578 !reverse_binds_p(ff
, print_lookup_to_xary
))
7580 struct stack_profiling
* found_profile
=
7581 klink_find_profile_in_frame (sc
->dump
, ff
);
7582 /* If the same combiner is already being profiled in this frame,
7583 don't add another copy. */
7586 /* $$IMPROVE ME Count tail calls */
7590 /* Push a profiling frame */
7591 _kt_spagstack old_frame
= sc
->dump
;
7592 _kt_spagstack frame
=
7594 GC_MALLOC (sizeof (dump_stack_frame_cell
));
7595 struct stack_profiling
* pdata
= &frame
->data
.profiling
;
7597 pdata
->initial_count
= k_profiling_count
;
7598 pdata
->returned_p
= 0;
7599 frame
->type
= ksct_profile
;
7600 frame
->next
= old_frame
;
7605 /*_ , When we pop a stack_profiling cell */
7607 k_profiling_done_frame(klink
* sc
, struct stack_profiling
* profile
)
7609 if(!k_profiling_p
) { return; }
7610 profiling_data
* pdata
= 0;
7611 pko ff
= profile
->ff
;
7613 /* This stack_profiling cell is popped past but it might be used
7614 again if we re-enter, so mark it accordingly. */
7615 profile
->returned_p
= 1;
7616 if(k_profiling_table
.alloced_size
== 0)
7617 { init_profile_table(&k_profiling_table
, 8); }
7620 int index
= objtable_get_index(k_profiling_table
.objs
, k_profiling_table
.table_size
, ff
);
7622 { pdata
= &k_profiling_table
.entries
[index
]; }
7625 /* Create it if needed */
7628 /* Increase size as needed */
7629 enlarge_profile_table(&k_profiling_table
);
7631 const int index
= k_profiling_table
.table_size
;
7632 k_profiling_table
.objs
[index
] = ff
;
7633 k_profiling_table
.table_size
++;
7634 pdata
= &k_profiling_table
.entries
[index
];
7635 /* Initialize it here */
7636 pdata
->num_calls
= 0;
7637 pdata
->num_evalloops
= 0;
7640 /* Add to its counts: Num calls. Num eval-loops taken. */
7642 pdata
->num_evalloops
+= k_profiling_count
- profile
->initial_count
;
7645 /*_ , Turn profiling on */
7646 /* Maybe better as a command-line switch or binder. */
7647 SIG_CHKARRAY(profiling
) = { REF_OPER(is_integer
), };
7648 DEF_SIMPLE_APPLICATIVE (ps0a1
, profiling
,T_NO_K
,ground
, "profiling")
7650 WITH_1_ARGS(profile_p
);
7651 int pr
= k_profiling_p
;
7652 k_profiling_p
= ivalue (profile_p
);
7653 return mk_integer (pr
);
7656 /*_ , Dumping profiling data */
7657 /* Return a list of the profiled combiners. */
7658 DEF_APPLICATIVE_W_DESTR(ps0a0
,get_profiling_data
,K_NO_TYPE
,T_NO_K
,ground
,"get-profiling-data")
7661 pko result_list
= K_NIL
;
7662 for(index
= 0; index
< k_profiling_table
.table_size
; index
++)
7664 pko ff
= k_profiling_table
.objs
[index
];
7665 profiling_data
* pdata
= &k_profiling_table
.entries
[index
];
7667 /* Element format: (object num-calls num-evalloops) */
7670 mk_integer(pdata
->num_calls
),
7671 mk_integer(pdata
->num_evalloops
)),
7674 /* Don't care about order so no need to reverse the list. */
7677 /*_ . Reset profiling data */
7678 /*_ , Alternative definitions for no profiling */
7680 #define k_profiling_step()
7681 #define k_profiling_new_frame(DUMMY, DUMMY2)
7683 /*_ . Error handling */
7684 /*_ , _klink_error_1 */
7686 _klink_error_1 (klink
* sc
, const char *s
, pko a
)
7689 const char *str
= s
;
7690 char sbuf
[STRBUFFSIZE
];
7691 pko the_inport
= klink_find_dyn_binding(sc
,K_INPORT
);
7692 if (the_inport
&& (the_inport
!= K_NIL
))
7694 port
* pt
= portvalue(the_inport
);
7695 /* Make sure error is not in REPL */
7696 if((pt
->kind
& port_file
) && (pt
->rep
.stdio
.file
!= stdin
))
7698 /* Count is 0-based but print it 1-based. */
7699 int ln
= pt
->rep
.stdio
.curr_line
+ 1;
7700 const char *fname
= pt
->rep
.stdio
.filename
;
7703 { fname
= "<unknown>"; }
7705 snprintf (sbuf
, STRBUFFSIZE
, "(%s : %i) %s", fname
, ln
, s
);
7707 str
= (const char *) sbuf
;
7711 const char *str
= s
;
7715 pko err_string
= mk_string (str
);
7718 err_arg
= mcons (a
, K_NIL
);
7724 err_arg
= mcons (err_string
, err_arg
);
7725 invoke_continuation (sc
, sc
->error_continuation
, err_arg
);
7731 /*_ , Default cheap error handlers */
7733 DEF_CFUNC (ps0a1
, kernel_err
, K_ANY
,0)
7738 putstr (sc
, "Error with no arguments. I know nut-ting!");
7741 if(!is_finite_list(arg1
))
7743 putstr (sc
, "kernel_err: arg must be a finite list");
7747 assert(is_pair(arg1
));
7748 int got_string
= is_string (car (arg1
));
7749 pko args_x
= got_string
? cdr (arg1
) : arg1
;
7750 const char *message
= got_string
? string_value (car (arg1
)) : " -- ";
7752 putstr (sc
, "Error: ");
7753 putstr (sc
, message
);
7754 return kernel_err_x (sc
, args_x
);
7757 /*_ . kernel_err_x */
7758 DEF_CFUNC (ps0a1
, kernel_err_x
, K_ANY_SINGLETON
,0)
7765 assert(is_pair(args
));
7766 CONTIN_1 (dcrry_1dotALL
, kernel_err_x
, sc
, cdr (args
));
7767 klink_push_dyn_binding(sc
,K_PRINT_FLAG
,K_T
);
7768 CONTIN_1 (dcrry_1dotALL
, kernel_print_sexp
, sc
, car (args
));
7777 /*_ . kernel_err_return */
7778 DEF_CFUNC(ps0a1
,kernel_err_return
, K_ANY
,0)
7780 /* This should not set sc->done, because when it's called it still
7781 must print the error, which may require more eval loops. */
7783 return kernel_err(sc
, arg1
);
7787 DEF_APPLICATIVE_W_DESTR(ps0a1
,error
,K_ANY
,0,ground
,"error")
7789 WITH_1_ARGS(err_arg
);
7790 invoke_continuation (sc
, sc
->error_continuation
, err_arg
);
7791 return 0; /* NOTREACHED */
7793 /*_ . error-descriptor? */
7794 /* $$WRITE ME TO replace the punted version */
7796 /*_ . Support for calling C functions */
7798 /*_ , klink_call_cfunc_aux */
7800 klink_call_cfunc_aux (klink
* sc
, const kt_cfunc
* p_cfunc
, pko
* arg_array
)
7802 switch (p_cfunc
->type
)
7804 /* For these macros, the arglist is parenthesized so is
7807 /* ***************************************** */
7808 /* For function types returning bool as int (bXXaX) */
7809 #define CASE_CFUNCTYPE_bX(SUFFIX,ARGLIST) \
7810 case klink_ftype_##SUFFIX: \
7811 return kernel_bool(p_cfunc->func.f_##SUFFIX ARGLIST)
7813 CASE_CFUNCTYPE_bX (b00a1
, (arg_array
[0]));
7814 CASE_CFUNCTYPE_bX (b00a2
, (arg_array
[0], arg_array
[1]));
7815 CASE_CFUNCTYPE_bX (bs0a2
, (sc
, arg_array
[0], arg_array
[1]));
7817 #undef CASE_CFUNCTYPE_bX
7820 /* ***************************************** */
7821 /* For function types returning pko (pXXaX) */
7822 #define CASE_CFUNCTYPE_pX(SUFFIX,ARGLIST) \
7823 case klink_ftype_##SUFFIX: \
7824 return p_cfunc->func.f_##SUFFIX ARGLIST
7826 CASE_CFUNCTYPE_pX (p00a0
, ());
7827 CASE_CFUNCTYPE_pX (p00a1
, (arg_array
[0]));
7828 CASE_CFUNCTYPE_pX (p00a2
, (arg_array
[0], arg_array
[1]));
7829 CASE_CFUNCTYPE_pX (p00a3
, (arg_array
[0], arg_array
[1], arg_array
[2]));
7831 CASE_CFUNCTYPE_pX (ps0a0
, (sc
));
7832 CASE_CFUNCTYPE_pX (ps0a1
, (sc
, arg_array
[0]));
7833 CASE_CFUNCTYPE_pX (ps0a2
, (sc
, arg_array
[0], arg_array
[1]));
7834 CASE_CFUNCTYPE_pX (ps0a3
, (sc
, arg_array
[0], arg_array
[1], arg_array
[2]));
7835 CASE_CFUNCTYPE_pX (ps0a4
, (sc
, arg_array
[0], arg_array
[1],
7836 arg_array
[2], arg_array
[3]));
7837 CASE_CFUNCTYPE_pX (ps0a5
, (sc
, arg_array
[0], arg_array
[1], arg_array
[2], arg_array
[3], arg_array
[4]));
7839 #undef CASE_CFUNCTYPE_pX
7842 /* ***************************************** */
7843 /* For function types returning void (vXXaX) */
7844 #define CASE_CFUNCTYPE_vX(SUFFIX,ARGLIST) \
7845 case klink_ftype_##SUFFIX: \
7846 p_cfunc->func.f_##SUFFIX ARGLIST; \
7849 CASE_CFUNCTYPE_vX (vs0a2
, (sc
, arg_array
[0], arg_array
[1]));
7850 CASE_CFUNCTYPE_vX (vs0a3
, (sc
, arg_array
[0], arg_array
[1], arg_array
[2]));
7852 #undef CASE_CFUNCTYPE_vX
7856 "kernel_call: About that function type, I know nut-ting!");
7859 /*_ , klink_call_cfunc */
7861 klink_call_cfunc (klink
* sc
, pko functor
, pko env
, pko args
)
7863 const kt_cfunc
* p_cfunc
= get_cfunc_func (functor
);
7864 assert(p_cfunc
->argcheck
);
7865 const int max_args
= destructure_how_many (p_cfunc
->argcheck
);
7866 pko arg_array
[max_args
];
7867 destructure_to_array(sc
,args
,
7871 REF_OPER (k_resume_to_cfunc
),
7873 return klink_call_cfunc_aux (sc
, p_cfunc
, arg_array
);
7875 /*_ , k_resume_to_cfunc */
7876 SIG_CHKARRAY (k_resume_to_cfunc
) =
7878 REF_OPER (is_destr_result
),
7879 REF_KEY (K_TYCH_DOT
),
7880 REF_OPER (is_cfunc
),
7882 DEF_SIMPLE_CFUNC (ps0a2
, k_resume_to_cfunc
, 0)
7884 WITH_2_ARGS (destr_result
, functor
);
7885 assert_type (0, functor
, T_CFUNC
);
7886 const int max_args
= 5;
7887 pko arg_array
[max_args
];
7888 destr_result_fill_array (destr_result
, max_args
, arg_array
);
7889 return klink_call_cfunc_aux (sc
, get_cfunc_func (functor
), arg_array
);
7891 /*_ . Some decurriers */
7893 dcrry_2A01VLL (klink
* sc
, pko args
, pko value
)
7896 return LIST2(car (args
), value
);
7898 static pko
dcrry_3A01dotVLL (klink
* sc
, pko args
, pko value
)
7901 return cons (car (args
), value
);
7904 dcrry_2CA01VLLA02 (klink
* sc
, pko args
, pko value
)
7907 return LIST2( cons (car (args
), value
), cadr (args
));
7909 /* May not be needed */
7911 dcrry_3A01A02VLL (klink
* sc
, pko args
, pko value
)
7914 return LIST3(car (args
), cadr (args
), value
);
7917 dcrry_2ALLVLL (klink
* sc
, pko args
, pko value
)
7919 return LIST2(args
, value
);
7921 static pko
dcrry_2ALLV01 (klink
* sc
, pko args
, pko value
)
7924 return LIST2(args
, car (value
));
7928 dcrry_NCVLLA01dotAX1 (klink
* sc
, pko args
, pko value
)
7931 return cons(cons (value
, car (args
)), cdr (args
));
7933 static pko
dcrry_NdotALL (klink
* sc
, pko args
, pko value
)
7936 static pko
dcrry_1ALL (klink
* sc
, pko args
, pko value
)
7937 { return cons( args
, K_NIL
); }
7939 static pko
dcrry_5ALLdotVLL (klink
* sc
, pko args
, pko value
)
7940 { return cons (args
, value
); }
7942 static pko
dcrry_NVLLdotALL (klink
* sc
, pko args
, pko value
)
7943 { return cons (value
, args
); }
7946 dcrry_1VLL (klink
* sc
, pko args
, pko value
)
7947 { return LIST1 (value
); }
7950 /*_ , Internal functions */
7951 /*_ . kernel_define_tree_aux */
7953 kernel_define_tree_aux
7954 (klink
* sc
, pko value
, pko formal
, pko env
, pko
* extra_result
)
7957 if (is_pair (formal
))
7959 if (is_pair (value
))
7961 kt_destr_outcome outcome
=
7962 kernel_define_tree_aux (sc
, car (value
), car (formal
), env
,
7967 /* $$IMPROVE ME On error, give a more accurate position. */
7969 kernel_define_tree_aux (sc
, cdr (value
), cdr (formal
), env
,
7973 case destr_must_call_k
:
7974 /* $$IMPROVE ME Also schedule to resume the cdr */
7975 /* Operations to run, in reverse order. */
7979 REF_OPER (kernel_define_tree
),
7980 /* V= (value formal env) */
7981 mk_load (LIST3 (cdr (value
),
7985 return destr_must_call_k
;
7987 errx (7, "Unrecognized enumeration");
7990 if (is_promise (value
))
7992 /* Operations to run, in reverse order. */
7996 REF_OPER (kernel_define_tree
),
7997 /* V= (forced-value formal env) */
7998 mk_load (LIST3 (mk_load_ix (0, 0),
8001 mk_store (K_ANY
, 1),
8002 /* V= forced-argobject */
8005 mk_load (LIST1 (value
)));
8006 return destr_must_call_k
;
8011 "kernel_define_tree: value must be a pair: ", value
);
8012 return destr_err
; /* NOTREACHED */
8015 /* We can encounter NIL at the end of a non-dotted list, so mustn't
8016 try to bind it, and value list must end here too. */
8017 else if (formal
== K_NIL
)
8022 "kernel_define_tree: too many args: ", value
);
8023 return destr_err
; /* NOTREACHED */
8025 return destr_success
;
8027 /* If formal is #ignore, don't try to bind it, do nothing. */
8028 else if (formal
== K_IGNORE
)
8030 return destr_success
;
8032 /* If it's a symbol, bind it. Even a promise is bound thus. */
8033 else if (is_symbol (formal
))
8035 kernel_define (env
, formal
, value
);
8036 return destr_success
;
8041 "kernel_define_tree: can't bind to: ", formal
);
8042 return destr_err
; /* NOTREACHED */
8045 /*_ . kernel_define_tree */
8046 /* This can no longer be assumed to be T_NO_K, in case promises must
8048 SIG_CHKARRAY(kernel_define_tree
) =
8049 { K_ANY
, K_ANY
, REF_OPER(is_environment
), };
8050 DEF_SIMPLE_CFUNC(vs0a3
,kernel_define_tree
,0)
8052 WITH_3_ARGS(value
, formal
, env
);
8054 kt_destr_outcome outcome
=
8055 kernel_define_tree_aux(sc
, value
, formal
, env
, &extra_result
);
8061 /* Later this may raise the error */
8063 case destr_must_call_k
:
8064 schedule_rv_list (sc
, extra_result
);
8067 errx (7, "Unrecognized enumeration");
8070 /*_ . kernel_define */
8071 SIG_CHKARRAY(kernel_define
) =
8073 REF_OPER(is_environment
),
8074 REF_OPER(is_symbol
),
8077 DEF_SIMPLE_CFUNC(p00a3
,kernel_define
,T_NO_K
)
8079 WITH_3_ARGS(env
, symbol
, value
);
8080 assert(is_symbol(symbol
));
8081 pko x
= find_slot_in_env (env
, symbol
, 0);
8084 set_slot_in_env (x
, value
);
8088 new_slot_spec_in_env (env
, symbol
, value
);
8092 void klink_define (klink
* sc
, pko symbol
, pko value
)
8093 { kernel_define(sc
->envir
,symbol
,value
); }
8095 /*_ , Supporting kernel registerables */
8096 /*_ . eval_define */
8097 RGSTR(ground
, "$define!", REF_OPER(eval_define
))
8098 SIG_CHKARRAY(eval_define
) =
8100 DEF_SIMPLE_CFUNC(ps0a2
,eval_define
,0)
8102 pko env
= sc
->envir
;
8103 WITH_2_ARGS(formal
, expr
);
8104 CONTIN_2(dcrry_3VLLdotALL
,kernel_define_tree
,sc
,formal
,env
);
8105 /* Using args functionality:
8111 RUN, in reverse order
8112 kernel_define_tree (CONTIN_0)
8113 make arglist from 3 args ($$WRITE MY SUPPORT) - or from 2 args and value.
8114 (The 2 slots will go here)
8115 put return value in new slot ($$WRITE MY SUPPORT)
8119 Possibly "make arglist" will be an array of integers, -1 meaning
8120 the current value. And on its own it could do decurrying.
8122 return kernel_eval(sc
,expr
,env
);
8125 RGSTR(ground
, "$set!", REF_OPER(set
))
8127 { K_ANY
, K_ANY
, K_ANY
, };
8128 DEF_SIMPLE_CFUNC(ps0a3
,set
,0)
8130 pko env
= sc
->envir
;
8131 WITH_3_ARGS(env_expr
, formal
, expr
);
8132 /* Using args functionality:
8134 RUN, in reverse order
8135 kernel_define_tree (CONTIN_0)
8136 make arglist from 3 args - or from 2 args and value.
8137 put return value in new slot
8139 make arglist from 1 arg
8142 put return value in new slot
8144 expr (Passed directly)
8148 CONTIN_0(kernel_define_tree
,sc
);
8150 kernel_mapeval(sc
, K_NIL
,
8152 LIST2(REF_OPER (arg1
), formal
),
8157 /*_ . Misc Kernel functions */
8160 SIG_CHKARRAY(tracing
) = { REF_OPER(is_integer
), };
8161 DEF_SIMPLE_APPLICATIVE (ps0a1
, tracing
,T_NO_K
,ground
, "tracing")
8163 WITH_1_ARGS(trace_p
);
8164 int tr
= sc
->tracing
;
8165 sc
->tracing
= ivalue (trace_p
);
8166 return mk_integer (tr
);
8169 /*_ , new_tracing */
8171 SIG_CHKARRAY(new_tracing
) = { REF_OPER(is_integer
), };
8172 DEF_SIMPLE_APPLICATIVE (ps0a1
, new_tracing
,T_NO_K
,ground
, "new-tracing")
8174 WITH_1_ARGS(trace_p
);
8175 int tr
= sc
->new_tracing
;
8176 sc
->new_tracing
= ivalue (trace_p
);
8177 return mk_integer (tr
);
8181 /*_ , get-current-environment */
8182 DEF_APPLICATIVE_W_DESTR (ps0a0
, get_current_environment
, K_NO_TYPE
,T_NO_K
,ground
, "get-current-environment")
8183 { return sc
->envir
; }
8185 /*_ , arg1, $quote, list */
8186 DEF_APPLICATIVE_W_DESTR (ps0a1
, arg1
, K_ANY_SINGLETON
,T_NO_K
,ground
, "identity")
8191 /* Same, unwrapped */
8192 RGSTR(ground
, "$quote", REF_OPER(arg1
))
8195 RGSTR(ground
, "list", REF_APPL(val2val
))
8196 /* The underlying C function here is "arg1", but it's called with
8197 the whole argobject as arg1 */
8198 /* K_ANY instead of REF_OPER(is_finite_list) because we deliberately allow
8199 non-lists and improper lists. */
8200 DEF_CFUNC_RAW(OPER(val2val
),ps0a1
,arg1
,K_ANY
,T_NO_K
);
8201 DEF_BOXED_APPLICATIVE(val2val
, REF_OPER (val2val
));
8204 RGSTR(ground
,"exit",REF_OPER(k_quit
))
8205 DEF_CFUNC(ps0a0
,k_quit
,K_NO_TYPE
,0)
8207 if(!nest_depth_ok_p(sc
))
8208 { sc
->retcode
= 1; }
8211 return K_INERT
; /* Value is unused anyways */
8214 RGSTR(ground
,"gc",REF_OPER(k_gc
))
8215 DEF_CFUNC(ps0a0
,k_gc
,K_NO_TYPE
,0)
8223 RGSTR(ground
, "$if", REF_OPER(k_if
))
8224 FORWARD_DECL_CFUNC(static,ps0a3
,k_if_literal
);
8225 SIG_CHKARRAY(k_if
) = { K_ANY
, K_ANY
, K_ANY
, };
8226 DEF_SIMPLE_DESTR( k_if
);
8229 /* Store (test consequent alternative) */
8230 ANON_STORE(REF_DESTR(k_if
)),
8232 ANON_LOAD(ANON_LIST1(ANON_LOAD_IX( 0, 0 ))),
8233 /* value = (test) */
8235 REF_OPER(kernel_eval
),
8237 /* Store (test_result) */
8240 ANON_LOAD(ANON_LIST3(ANON_LOAD_IX( 0, 0 ),
8241 ANON_LOAD_IX( 1, 1 ),
8242 ANON_LOAD_IX( 1, 2 ))),
8244 /* test_result, consequent, alternative */
8245 REF_OPER(k_if_literal
),
8248 DEF_SIMPLE_CHAIN(k_if
);
8250 SIG_CHKARRAY(k_if_literal
) = { REF_OPER(is_bool
), K_ANY
, K_ANY
, };
8251 DEF_SIMPLE_CFUNC(ps0a3
,k_if_literal
,0)
8253 WITH_3_ARGS(test
, consequent
, alternative
);
8254 if(test
== K_T
) { return kernel_eval(sc
, consequent
, sc
->envir
); }
8255 if(test
== K_F
) { return kernel_eval(sc
, alternative
, sc
->envir
); }
8256 KERNEL_ERROR_1(sc
,"Must be a boolean: ", test
);
8259 /*_ . Routines for applicatives */
8260 BOX_OF_VOID (K_APPLICATIVE
);
8262 DEF_SIMPLE_PRED (is_applicative
,T_NO_K
,ground
, "applicative?/o1")
8265 return is_encap (REF_KEY(K_APPLICATIVE
), p
);
8268 DEF_SIMPLE_PRED (is_combiner
,T_NO_K
,ground
, "combiner?/o1")
8271 return is_applicative(p
) || is_operative(p
);
8274 SIG_CHKARRAY(wrap
) = { REF_OPER(is_combiner
) };
8275 DEF_SIMPLE_APPLICATIVE (p00a1
, wrap
,T_NO_K
,ground
, "wrap")
8278 return mk_encap (REF_KEY(K_APPLICATIVE
), p
);
8281 SIG_CHKARRAY(unwrap
) = { REF_OPER(is_applicative
) };
8282 DEF_SIMPLE_APPLICATIVE (ps0a1
, unwrap
,T_NO_K
,ground
, "unwrap")
8285 return unencap (sc
, REF_KEY(K_APPLICATIVE
), p
);
8288 SIG_CHKARRAY(unwrap_all
) = { REF_OPER(is_combiner
) };
8289 DEF_SIMPLE_APPLICATIVE (p00a1
, unwrap_all
,T_NO_K
,ground
, "unwrap-all")
8292 /* Wrapping does not allowing circular wrapping, so this will
8294 while(is_encap (REF_KEY(K_APPLICATIVE
), p
))
8295 { p
= unencap (0, REF_KEY(K_APPLICATIVE
), p
); }
8301 /*_ , is_operative */
8302 /* This can be hacked quicker by suppressing 1 more bit and testing
8303 * just once. Requires keeping those T_ types co-ordinated, though. */
8304 DEF_SIMPLE_PRED (is_operative
,T_NO_K
,ground
, "operative?/o1")
8308 is_type (p
, T_CFUNC
)
8309 || is_type (p
, T_CFUNC_RESUME
)
8310 || is_type (p
, T_CURRIED
)
8311 || is_type (p
, T_LISTLOOP
)
8312 || is_type (p
, T_CHAIN
)
8313 || is_type (p
, T_STORE
)
8314 || is_type (p
, T_LOAD
)
8315 || is_type (p
, T_TYPEP
);
8319 RGSTR(simple
, "$vau/3", REF_OPER(vau_1
))
8321 /* This is a simple vau for bootstrap. It handles just a single
8322 expression. It's in ground for now, but will be only in
8323 low-for-optimization later */
8325 /* $$IMPROVE ME Check that formals is a non-circular list with no
8326 duplicated symbols. If this check is typical for
8327 kernel_define_tree (probably), pass that an initially blank
8328 environment and it can check for symbols and error if they are
8331 eformal is almost REF_OPER(is_symbol) but must accept #ignore also.
8333 SIG_CHKARRAY(vau_1
) = { K_ANY
, K_ANY
, K_ANY
};
8334 DEF_SIMPLE_CFUNC (ps0a3
, vau_1
,0)
8336 pko env
= sc
->envir
;
8337 WITH_3_ARGS(formals
, eformal
, expression
);
8338 /* This defines a vau object. Evaluating it is different.
8341 /* $$IMPROVE ME Could compile the expression now, but that's not so
8342 easy in Kernel. At least make a hook for that. */
8344 /* Vau data is a list of the 4 things:
8345 The dynamic environment
8347 An immutable copy of the formals es
8348 An immutable copy of the expression
8350 $$IMPROVE ME Make not a list but a dedicated struct.
8355 copy_es_immutable(sc
, formals
),
8356 copy_es_immutable (sc
, expression
));
8358 mk_curried (dcrry_5VLLdotALL
, vau_data
, REF_OPER (eval_vau
));
8361 /*_ . Evaluation, Kernel style */
8362 /*_ , Calling operatives */
8364 /* Again, can't simply say REF_OPER(is_symbol) because it might be
8366 SIG_CHKARRAY(eval_vau
) =
8368 REF_OPER(is_environment
),
8372 DEF_SIMPLE_CFUNC (ps0a5
, eval_vau
,0)
8374 pko env
= sc
->envir
;
8375 WITH_5_ARGS(args
, old_env
, eformal
, formals
, expression
);
8377 /* Make a new environment, child of the static environment (which
8378 we get now while making the vau) and put it into the envir
8380 new_frame_in_env (sc
, old_env
);
8382 /* This will change in kernel_define, not here. */
8383 /* Bind the dynamic environment to the eformal symbol. */
8384 kernel_define_tree (sc
, env
, eformal
, sc
->envir
);
8386 /* Bind the formals (symbols) to the operands (values) treewise. */
8388 kt_destr_outcome outcome
=
8389 kernel_define_tree_aux(sc
, args
, formals
, sc
->envir
, &extra_result
);
8395 /* Later this may raise the error */
8397 case destr_must_call_k
:
8398 CONTIN_2 (dcrry_2dotALL
, kernel_eval
, sc
, expression
, sc
->envir
);
8399 schedule_rv_list (sc
, extra_result
);
8402 errx (7, "Unrecognized enumeration");
8405 /* Evaluate the expression. */
8406 return kernel_eval (sc
, expression
, sc
->envir
);
8409 /*_ , Kernel eval mutual callers */
8410 /*_ . kernel_eval */
8412 /* Optionally define a tracing kernel_eval */
8413 SIG_CHKARRAY(kernel_eval
) = { K_ANY
, REF_KEY(K_TYCH_OPTIONAL
), REF_OPER(is_environment
), };
8414 DEF_SIMPLE_DESTR(kernel_eval
);
8416 FORWARD_DECL_CFUNC(static,ps0a2
,kernel_real_eval
);
8417 DEF_APPLICATIVE_W_DESTR (ps0a2
, kernel_eval
, REF_DESTR(kernel_eval
),0,ground
, "eval")
8419 WITH_2_ARGS(form
, env
);
8420 /* $$RETHINK ME Set sc->envir here, remove arg from
8421 kernel_real_eval, and the tracing call will know its own env,
8422 it may just be a closure with form as value. */
8429 CONTIN_2 (dcrry_2dotALL
, kernel_real_eval
, sc
, form
, env
);
8430 putstr (sc
, "\nEval: ");
8431 CONTIN_1 (dcrry_1dotALL
, kernel_print_sexp
, sc
, form
);
8436 return kernel_real_eval (sc
, form
, env
);
8441 /* Define either kernel_eval (if not defined above) or kernel_real_eval */
8443 /* $$IMPROVE MY DESIGN Don't like the pointers being different
8444 levels of pointingness. In fact, we always potentially have
8445 tracing (or w/e) so let's lose the preprocessor condition. */
8447 DEF_CFUNC (ps0a2
, kernel_real_eval
, REF_DESTR(kernel_eval
),0)
8449 DEF_APPLICATIVE_W_DESTR (ps0a2
, kernel_eval
, REF_DESTR(kernel_eval
),0,ground
, "eval")
8453 WITH_2_ARGS(form
, env
);
8455 /* Evaluate form in env */
8457 form: form to be evaluated
8458 env: environment to evaluate it in.
8462 /* $$IMPROVE ME Let this be done in kernel_eval and lose the env
8463 argument, here just assert that we have an environment. */
8466 if (is_environment (env
))
8467 { sc
->envir
= env
; }
8470 KERNEL_ERROR_0 (sc
, "eval: Arg 2 must be an environment:");
8474 if (is_symbol (form
))
8476 pko x
= find_slot_in_env (env
, form
, 1);
8479 return slot_value_in_env (x
);
8483 KERNEL_ERROR_1 (sc
, "eval: unbound variable:", form
);
8487 else if (is_pair (form
))
8489 CONTIN_2 (dcrry_3VLLdotALL
, kernel_eval_aux
, sc
, cdr (form
), env
);
8490 return kernel_eval (sc
, car (form
), env
);
8492 /* Otherwise return the object literally. */
8498 /*_ . kernel_eval_aux */
8499 /* The stage of `eval' when we've already decided that we're to use a
8500 combiner and what that combiner is. */
8501 /* $$IMPROVE ME Lose the env argument, it's always sc->envir */
8502 SIG_CHKARRAY(kernel_eval_aux
) =
8503 { REF_OPER(is_combiner
), K_ANY
, REF_OPER(is_environment
), };
8504 DEF_SIMPLE_DESTR(kernel_eval_aux
);
8505 DEF_CFUNC (ps0a3
, kernel_eval_aux
, REF_DESTR(kernel_eval_aux
),0)
8507 WITH_3_ARGS(functor
, args
, env
);
8508 assert (is_environment (env
));
8510 functor: what the car of the form has evaluated to.
8511 args: cdr of form, as yet unevaluated.
8512 env: environment to evaluate in.
8514 k_profiling_new_frame(sc
, functor
);
8515 if(is_type(functor
, T_CFUNC
))
8517 return klink_call_cfunc(sc
, functor
, env
, args
);
8519 else if(is_type(functor
, T_CURRIED
))
8521 return call_curried(sc
, functor
, args
);
8523 else if(is_type(functor
, T_TYPEP
))
8525 /* $$MOVE ME Into something paralleling the other operative calls */
8526 /* $$IMPROVE ME Check arg number */
8529 { KERNEL_ERROR_1 (sc
, "Takes one arg: ", functor
); }
8530 return kernel_bool(call_T_typecheck(functor
,car(args
)));
8532 else if(is_type(functor
, T_LISTLOOP
))
8534 return eval_listloop(sc
, functor
,args
);
8536 else if(is_type(functor
, T_CHAIN
))
8538 return eval_chain( sc
, functor
, args
);
8540 else if ( is_type( functor
, T_STORE
))
8542 return k_do_store( sc
, functor
, args
);
8544 else if ( is_type( functor
, T_LOAD
))
8546 return k_do_load( sc
, functor
, args
);
8548 else if (is_applicative (functor
))
8551 Get the underlying operative.
8552 Evaluate arguments (may make frames)
8553 Use the oper on the arguments
8555 pko oper
= unwrap (sc
, functor
);
8558 get_list_metrics_aux(args
, metrics
);
8559 if(metrics
[lm_cyc_len
] != 0)
8561 KERNEL_ERROR_1 (sc
, "kernel_eval_aux: Arguments must be a list", args
);
8563 sc
->envir
= env
; /* $$IMPROVE ME Treat this cache better */
8564 CONTIN_2 (dcrry_2CA01VLLA02
, kernel_eval
, sc
, oper
, env
);
8568 CONTIN_3 (dcrry_4dotALL
, kernel_mapeval
, sc
, K_NIL
, args
, env
);
8569 CONTIN_1 (dcrry_1dotALL
, kernel_print_sexp
, sc
, args
);
8570 putstr (sc
, "\nApply to: ");
8575 { return kernel_mapeval (sc
, K_NIL
, args
, env
); }
8579 KERNEL_ERROR_1 (sc
, "eval: can't apply:", functor
);
8582 /*_ , Eval mappers */
8583 /*_ . kernel_mapeval */
8584 /* Evaluate each datum in list arg2, Kernel-returning a list of the results. */
8585 SIG_CHKARRAY(kernel_mapeval
) =
8586 { REF_OPER(is_finite_list
), REF_OPER(is_finite_list
), REF_OPER(is_environment
), };
8587 DEF_SIMPLE_DESTR(kernel_mapeval
);
8588 DEF_CFUNC (ps0a3
, kernel_mapeval
, REF_DESTR(kernel_mapeval
),0)
8591 WITH_3_ARGS(accum
, args
, env
);
8592 assert (is_environment (env
));
8595 * The list of evaluated arguments, in reverse order.
8596 * Purpose: Used as an accumulator.
8598 args: list of forms to be evaluated.
8599 * Precondition: Must be a proper list (is_list must give true)
8600 * When called by itself: The forms that remain yet to be evaluated
8602 env: The environment to evaluate in.
8605 /* If there are remaining arguments, arrange to evaluate one,
8606 add the result to accumulator, and return control here. */
8609 /* This can't be converted to a loop because we don't know
8610 whether kernel_eval_aux will create more frames. */
8611 CONTIN_3 (dcrry_3CVLLA01dotAX1
,
8612 kernel_mapeval
, sc
, accum
, cdr (args
), env
);
8613 return kernel_eval (sc
, car (args
), env
);
8615 /* If there are no remaining arguments, reverse the accumulator
8616 and return it. Can't reverse in place because other
8617 continuations might re-use the same accumulator state. */
8618 else if (args
== K_NIL
)
8619 { return reverse (sc
, accum
); }
8622 /* This shouldn't be reachable because we check for it being
8623 a list beforehand in kernel_eval_aux. */
8624 errx (4, "mapeval: arguments must be a list:");
8628 RGSTR(ground
,"$bad-sequence",REF_OPER(kernel_sequence
))
8629 SIG_CHKARRAY(kernel_sequence
) =
8630 { REF_KEY(K_TYCH_DOT
), REF_OPER(is_countable_list
), };
8631 DEF_SIMPLE_CFUNC(ps0a1
,kernel_sequence
,0)
8634 /* Ultimately return #inert */
8635 /* $$IMPROVE ME This shouldn't accumulate args only to discard
8637 CONTIN_0_RAW(mk_curried(dcrry_NdotALL
, K_INERT
, 0), sc
);
8638 return kernel_mapeval(sc
,K_NIL
,forms
,sc
->envir
);
8641 /*_ . kernel_mapand_aux */
8642 /* Call proc on each datum in args, Kernel-returning true if all
8643 succeed, otherwise false. */
8644 SIG_CHKARRAY(kernel_mapand_aux
) =
8645 { REF_OPER(is_bool
),
8646 REF_OPER(is_combiner
),
8647 REF_OPER(is_finite_list
),
8649 DEF_SIMPLE_CFUNC (ps0a3
, kernel_mapand_aux
,0)
8652 WITH_3_ARGS(ok
, proc
, args
);
8655 * Whether the last invocation of this succeeded. Initialize with
8658 * proc: A boolean combiner (predicate) to apply to these objects
8660 * args: list of objects to apply proc to
8661 * Precondition: Must be a proper list
8666 { KERNEL_ERROR_1(sc
, "kernel_mapand_aux: Must be boolean: ", ok
); }
8667 /* If there are remaining arguments, arrange to evaluate one and
8668 return control here. */
8671 /* This can't be converted to a loop because we don't know
8672 whether kernel_eval_aux will create more frames. */
8673 CONTIN_2 (dcrry_3VLLdotALL
,
8674 kernel_mapand_aux
, sc
, proc
, cdr (args
));
8675 return kernel_eval_aux (sc
, proc
, car (args
), sc
->envir
);
8677 /* If there are no remaining arguments, return true. */
8678 else if (args
== K_NIL
)
8682 /* This shouldn't be reachable because we check for it being a
8684 errx (4, "mapbool: arguments must be a list:");
8688 /*_ . kernel_mapand */
8689 SIG_CHKARRAY(kernel_mapand
) =
8690 { REF_OPER(is_combiner
),
8691 REF_OPER(is_finite_list
),
8693 DEF_SIMPLE_APPLICATIVE (ps0a2
, kernel_mapand
,0,simple
, "every?/2-xary")
8695 WITH_2_ARGS(proc
, args
);
8696 /* $$IMPROVE ME Get list metrics here and if we get a circular
8697 list, treat it correctly (How is TBD). */
8698 return kernel_mapand_aux(sc
,REF_KEY(K_T
), proc
, args
);
8700 /*_ . kernel_mapor_aux */
8701 /* Call proc on each datum in args, Kernel-returning true if all
8702 succeed, otherwise false. */
8703 SIG_CHKARRAY(kernel_mapor_aux
) =
8704 { REF_OPER(is_bool
),
8705 REF_OPER(is_combiner
),
8706 REF_OPER(is_finite_list
),
8708 DEF_SIMPLE_CFUNC (ps0a3
, kernel_mapor_aux
,0)
8711 WITH_3_ARGS(ok
, proc
, args
);
8714 * Whether the last invocation of this succeeded. Initialize with
8717 * proc: A boolean combiner (predicate) to apply to these objects
8719 * args: list of objects to apply proc to
8720 * Precondition: Must be a proper list
8725 { KERNEL_ERROR_1(sc
, "kernel_mapor_aux: Must be boolean: ", ok
); }
8726 /* If there are remaining arguments, arrange to evaluate one and
8727 return control here. */
8730 /* This can't be converted to a loop because we don't know
8731 whether kernel_eval_aux will create more frames. */
8732 CONTIN_2 (dcrry_3VLLdotALL
,
8733 kernel_mapor_aux
, sc
, proc
, cdr (args
));
8734 return kernel_eval_aux (sc
, proc
, car (args
), sc
->envir
);
8736 /* If there are no remaining arguments, return false. */
8737 else if (args
== K_NIL
)
8741 /* This shouldn't be reachable because we check for it being a
8743 errx (4, "mapbool: arguments must be a list:");
8746 /*_ . kernel_mapor */
8747 SIG_CHKARRAY(kernel_mapor
) =
8748 { REF_OPER(is_combiner
),
8749 REF_OPER(is_finite_list
),
8751 DEF_SIMPLE_APPLICATIVE (ps0a2
, kernel_mapor
,0,simple
, "some?/2-xary")
8753 WITH_2_ARGS(proc
, args
);
8754 /* $$IMPROVE ME Get list metrics here and if we get a circular
8755 list, treat it correctly (How is TBD). */
8756 return kernel_mapor_aux(sc
,REF_KEY(K_F
), proc
, args
);
8759 /*_ , Kernel combiners */
8761 /* $$IMPROVE ME Make referring to curried operatives neater. */
8762 RGSTR(ground
, "$and?", REF_OBJ(k_oper_andp
))
8763 DEF_BOXED_CURRIED(k_oper_andp
,
8765 REF_OPER(kernel_internal_eval
),
8766 REF_OPER(kernel_mapand
));
8769 RGSTR(ground
, "$or?", REF_OBJ(k_oper_orp
))
8770 DEF_BOXED_CURRIED(k_oper_orp
,
8772 REF_OPER(kernel_internal_eval
),
8773 REF_OPER(kernel_mapor
));
8776 /*_ . k_counted_map_aux */
8777 /* $$USE ME MORE Export both to simple: "counted-map1-car"
8778 "counted-map1-cdr" */
8780 k_counted_map_car(klink
* sc
, int count
, pko list
, _kt_tag t_enum
)
8783 pko rv_result
= K_NIL
;
8784 for(i
= 0; i
< count
; ++i
, list
= pair_cdr(0, list
))
8786 assert(is_pair(list
));
8787 pko obj
= pair_car(0, list
);
8788 rv_result
= v2cons (t_enum
, pair_car(sc
, obj
), rv_result
);
8791 /* Reverse the list in place. */
8792 return unsafe_v2reverse_in_place(K_NIL
, rv_result
);
8796 k_counted_map_cdr(klink
* sc
, int count
, pko list
, _kt_tag t_enum
)
8799 pko rv_result
= K_NIL
;
8800 for(i
= 0; i
< count
; ++i
, list
= pair_cdr(0, list
))
8802 assert(is_pair(list
));
8803 pko obj
= pair_car(0, list
);
8804 rv_result
= v2cons (t_enum
, pair_cdr(sc
, obj
), rv_result
);
8807 /* Reverse the list in place. */
8808 return unsafe_v2reverse_in_place(K_NIL
, rv_result
);
8811 /* Evaluate COUNT datums in list ARGS, Kernel-returning a list of the
8813 SIG_CHKARRAY(k_counted_map_aux
) =
8814 { REF_OPER(is_finite_list
),
8815 REF_OPER(is_integer
),
8816 REF_OPER(is_integer
),
8817 REF_OPER(is_operative
),
8818 REF_OPER(is_finite_list
),
8820 DEF_SIMPLE_APPLICATIVE (ps0a5
, k_counted_map_aux
, 0,simple
, "counted-map/5")
8822 WITH_5_ARGS(accum
, count
, len
, oper
, args
);
8823 assert (is_integer (count
));
8824 /* $$IMPROVE ME Check the other args too */
8828 * The list of evaluated arguments, in reverse order.
8829 * Purpose: Used as an accumulator.
8832 * The number of arguments remaining
8835 * The effective length of args.
8840 args: list of lists of arguments to this.
8842 * Precondition: Must be a proper list (is_finite_list must give
8843 true). args will not be cyclic, we'll check for and handle
8844 encycling outside of here.
8847 /* If there are remaining arguments, arrange to operate on one, cons
8848 the result to accumulator, and return control here. */
8849 if (ivalue (count
) > 0)
8851 assert(is_pair(args
));
8852 int len_v
= ivalue(len
);
8853 /* This can't be converted to a loop because we don't know
8854 whether kernel_eval_aux will create more frames.
8856 $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8858 CONTIN_5 (dcrry_5CVLLA01dotAX1
,
8859 k_counted_map_aux
, sc
, accum
,
8860 mk_integer(ivalue(count
) - 1),
8863 k_counted_map_cdr(sc
, len_v
, args
, T_PAIR
));
8865 return kernel_eval_aux (sc
,
8867 k_counted_map_car(sc
, len_v
, args
, T_PAIR
),
8870 /* If there are no remaining arguments, reverse the accumulator
8871 and return it. Can't reverse in place because other
8872 continuations might re-use the same accumulator state. */
8874 { return reverse (sc
, accum
); }
8878 /*_ . counted-every?/5 */
8879 SIG_CHKARRAY(k_counted_every
) =
8880 { REF_OPER(is_bool
),
8881 REF_OPER(is_integer
),
8882 REF_OPER(is_integer
),
8883 REF_OPER(is_operative
),
8884 REF_OPER(is_finite_list
),
8886 DEF_SIMPLE_APPLICATIVE (ps0a5
, k_counted_every
,0,simple
,"counted-every?/5")
8888 WITH_5_ARGS(ok
, count
, len
, oper
, args
);
8889 assert (is_bool (ok
));
8890 assert (is_integer (count
));
8891 assert (is_integer (len
));
8895 * Whether the last invocation of this succeeded. Initialize with
8899 * The number of arguments remaining
8902 * The effective length of args.
8907 args: list of lists of arguments to this.
8909 * Precondition: Must be a proper list (is_finite_list must give
8910 true). args will not be cyclic, we'll check for and handle
8911 encycling outside of here.
8917 { KERNEL_ERROR_1(sc
, "k_counted_every: Must be boolean: ", ok
); }
8919 /* If there are remaining arguments, arrange to evaluate one and
8920 return control here. */
8921 if (ivalue (count
) > 0)
8923 assert(is_pair(args
));
8924 int len_v
= ivalue(len
);
8925 /* This can't be converted to a loop because we don't know
8926 whether kernel_eval_aux will create more frames.
8928 $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8930 CONTIN_4 (dcrry_4VLLdotALL
,
8931 k_counted_every
, sc
,
8932 mk_integer(ivalue(count
) - 1),
8935 k_counted_map_cdr(sc
, len_v
, args
, T_PAIR
));
8937 return kernel_eval_aux (sc
,
8939 k_counted_map_car(sc
, len_v
, args
, T_PAIR
),
8942 /* If there are no remaining arguments, return true. */
8948 /*_ . counted-some?/5 */
8949 SIG_CHKARRAY(k_counted_some
) =
8950 { REF_OPER(is_bool
),
8951 REF_OPER(is_integer
),
8952 REF_OPER(is_integer
),
8953 REF_OPER(is_operative
),
8954 REF_OPER(is_finite_list
),
8956 DEF_SIMPLE_APPLICATIVE (ps0a5
, k_counted_some
,0,simple
,"counted-some?/5")
8958 WITH_5_ARGS(ok
, count
, len
, oper
, args
);
8959 assert (is_bool (ok
));
8960 assert (is_integer (count
));
8961 assert (is_integer (len
));
8966 { KERNEL_ERROR_1(sc
, "k_counted_some: Must be boolean: ", ok
); }
8968 /* If there are remaining arguments, arrange to evaluate one and
8969 return control here. */
8970 if (ivalue (count
) > 0)
8972 assert(is_pair(args
));
8973 int len_v
= ivalue(len
);
8974 /* This can't be converted to a loop because we don't know
8975 whether kernel_eval_aux will create more frames.
8977 $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8979 CONTIN_4 (dcrry_4VLLdotALL
,
8981 mk_integer(ivalue(count
) - 1),
8984 k_counted_map_cdr(sc
, len_v
, args
, T_PAIR
));
8986 return kernel_eval_aux (sc
,
8988 k_counted_map_car(sc
, len_v
, args
, T_PAIR
),
8991 /* If there are no remaining arguments, return false. */
8997 /*_ . Klink top level */
8998 /*_ , kernel_repl */
8999 DEF_CFUNC(ps0a0
, kernel_repl
, K_NO_TYPE
,0)
9001 /* If we reached the end of file, this loop is done. */
9002 port
*pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
9004 if (pt
->kind
& port_saw_EOF
)
9008 putstr (sc
, prompt
);
9010 assert (is_environment (sc
->envir
));
9012 /* Arrange another iteration */
9013 CONTIN_0 (kernel_repl
, sc
);
9014 klink_push_dyn_binding(sc
,K_PRINT_FLAG
,K_T
);
9015 klink_push_cont(sc
, REF_OBJ(print_value
));
9017 CONTIN_1 (dcrry_2A01VLL
, tracing_say
, sc
, mk_string("\nGives: "));
9019 CONTIN_0 (kernel_internal_eval
, sc
);
9020 CONTIN_0 (kernel_read_internal
, sc
);
9025 static const kt_vector rel_chain
=
9030 REF_OPER(kernel_read_internal
),
9031 REF_OPER(kernel_internal_eval
),
9032 REF_OPER(kernel_rel
),
9036 DEF_CFUNC(ps0a0
, kernel_rel
, K_NO_TYPE
,0)
9038 /* If we reached the end of file, this loop is done. */
9039 port
*pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
9041 if (pt
->kind
& port_saw_EOF
)
9044 assert (is_environment (sc
->envir
));
9047 schedule_chain( sc
, &rel_chain
);
9049 /* Arrange another iteration */
9050 CONTIN_0 (kernel_rel
, sc
);
9051 CONTIN_0 (kernel_internal_eval
, sc
);
9052 CONTIN_0 (kernel_read_internal
, sc
);
9057 /*_ , kernel_internal_eval */
9058 /* Convert the aftermath of kernel_read_internal to something kernel_eval
9060 /* $$IMPROVE ME realize this as a currier. But it's not a curried
9061 object as such because it carries no internal data. */
9062 DEF_CFUNC (ps0a1
, kernel_internal_eval
, K_ANY
,0)
9065 if( sc
->new_tracing
)
9066 { klink_push_dyn_binding( sc
, K_TRACING
, K_T
); }
9067 return kernel_eval (sc
, value
, sc
->envir
);
9070 /*_ . Constructing environments */
9071 /*_ , Declarations for built-in environments */
9072 /* These are initialized before they are registered. */
9073 static pko print_lookup_env
= 0;
9074 static pko all_builtins_env
= 0;
9075 static pko ground_env
= 0;
9076 #define unsafe_env ground_env
9077 #define simple_env ground_env
9078 static pko typecheck_env_syms
= 0;
9080 /*_ , What to include */
9081 #ifndef COLLECT_RGSTRS /* If we're collecting, these files may not
9082 have been generated yet */
9083 const kernel_registerable preregister
[] =
9085 /* $$MOVE ME These others will move into dedicated arrays, and be
9086 combined so that they can all be seen in init.krn but not in
9088 #include "registerables/ground.inc"
9089 #include "registerables/unsafe.inc"
9090 #include "registerables/simple.inc"
9091 /* $$TRANSITIONAL */
9092 { "type?", REF_APPL(typecheck
), },
9093 { "do-destructure", REF_APPL(do_destructure
), },
9096 const kernel_registerable all_builtins
[] =
9098 #include "registerables/all-builtins.inc"
9101 const kernel_registerable print_lookup_rgsts
[] =
9103 { "#f", REF_KEY(K_F
), },
9104 { "#t", REF_KEY(K_T
), },
9105 { "#inert", REF_KEY(K_INERT
), },
9106 { "#ignore", REF_KEY(K_IGNORE
), },
9108 { "$quote", REF_OPER(arg1
), },
9110 /* $$IMPROVE ME Add the other quote-like symbols here. */
9111 /* quasiquote, unquote, unquote-splicing */
9115 const kernel_registerable typecheck_syms_rgsts
[] =
9117 #include "registerables/type-keys.inc"
9124 /* Bind each of an array of kernel_registerables into env. */
9126 k_register_list (const kernel_registerable
* list
, int count
, pko env
)
9130 assert (is_environment (env
));
9131 for (i
= 0; i
< count
; i
++)
9133 kernel_define (env
, mk_symbol (list
[i
].name
), list
[i
].data
);
9137 /*_ , k_regstrs_to_env */
9139 k_regstrs_to_env(const kernel_registerable
* list
, int count
)
9141 pko env
= make_new_frame(K_NIL
);
9142 k_register_list (list
, count
, env
);
9146 #define K_REGSTRS_TO_ENV(RGSTRS)\
9147 k_regstrs_to_env(RGSTRS, sizeof (RGSTRS) / sizeof (RGSTRS[0]))
9148 /*_ , setup_print_secondary_lookup */
9149 static pko print_lookup_unwraps
= 0;
9150 static pko print_lookup_to_xary
= 0;
9152 setup_print_secondary_lookup(void)
9154 /* Quick and dirty: Set up tables corresponding to the ground env
9155 and put the registering stuff in them. */
9156 /* What this really accomplishes is to make prepared lookup tables
9157 available for particular print operations. Later we'll use a
9158 more general approach and this will become just a cache. */
9159 print_lookup_unwraps
= make_new_frame(K_NIL
);
9160 print_lookup_to_xary
= make_new_frame(K_NIL
);
9162 const kernel_registerable
* list
= preregister
;
9163 int count
= sizeof (preregister
) / sizeof (preregister
[0]);
9164 for (i
= 0; i
< count
; i
++)
9166 pko obj
= list
[i
].data
;
9167 if(is_applicative(obj
))
9169 kernel_define (print_lookup_unwraps
,
9170 mk_symbol (list
[i
].name
),
9173 pko xary
= k_to_trivpred(obj
);
9174 if((xary
!= K_NIL
) && xary
!= obj
)
9176 kernel_define (print_lookup_to_xary
,
9177 mk_symbol (list
[i
].name
),
9183 /*_ , make-kernel-standard-environment */
9184 /* Though it would be neater for this to define ground environment if
9185 there is none, that would mean it would need the eval loop and so
9186 couldn't be done early. So it relies on the ground environment
9187 being already defined. */
9188 RGSTR(ground
,"make-kernel-standard-environment", REF_OPER(mk_std_environment
))
9189 DEF_CFUNC(p00a0
, mk_std_environment
, K_NO_TYPE
,T_NO_K
)
9192 return make_new_frame(ground_env
);
9195 /*_ . The eval cycle */
9197 /*_ . Make an error continuation */
9199 klink_record_error_cont (klink
* sc
, pko error_continuation
)
9201 /* Record error continuation. */
9202 kernel_define (sc
->envir
,
9203 mk_symbol ("error-continuation"),
9204 error_continuation
);
9205 /* Also record it in interpreter, so built-ins can see it w/o
9207 sc
->error_continuation
= error_continuation
;
9210 /*_ , Entry points */
9211 /*_ . Eval cycle that restarts on error */
9213 klink_cycle_restarting (klink
* sc
, pko combiner
)
9215 assert(is_combiner(combiner
));
9216 assert(is_environment(sc
->envir
));
9217 /* Arrange to stop if we ever reach where we started. */
9218 klink_push_cont (sc
, REF_OPER (k_quit
));
9220 /* Grab root continuation. */
9221 kernel_define (sc
->envir
,
9222 mk_symbol ("root-continuation"),
9223 current_continuation (sc
));
9225 /* Make main continuation */
9226 klink_push_cont (sc
, combiner
);
9228 /* Make error continuation on top of main continuation. */
9229 pko error_continuation
=
9230 extend_continuation_aux(sc
->dump
, REF_OPER(kernel_err
), sc
->envir
);
9232 klink_record_error_cont(sc
, error_continuation
);
9234 /* Conceptually sc->retcode is a keyed dynamic variable that
9238 /* $$RECONSIDER ME Maybe indicate quit value */
9240 /*_ . Eval cycle that terminates on error */
9242 klink_cycle_no_restart (klink
* sc
, pko combiner
)
9244 assert(is_combiner(combiner
));
9245 assert(is_environment(sc
->envir
));
9246 /* Arrange to stop if we ever reach where we started. */
9247 klink_push_cont (sc
, REF_OPER (k_quit
));
9249 /* Grab root continuation. */
9250 kernel_define (sc
->envir
,
9251 mk_symbol ("root-continuation"),
9252 current_continuation (sc
));
9254 /* Make error continuation that quits. */
9255 pko error_continuation
=
9256 extend_continuation_aux(sc
->dump
, REF_OPER(kernel_err_return
), sc
->envir
);
9258 klink_record_error_cont(sc
, error_continuation
);
9260 klink_push_cont (sc
, combiner
);
9262 /* Conceptually sc->retcode is a keyed dynamic variable that
9263 kernel_err sets. Actually it's entirely cached in the
9270 /*_ , _klink_cycle (Don't use this directly) */
9272 _klink_cycle (klink
* sc
)
9274 pko value
= K_INERT
;
9279 int i
= setjmp (sc
->pseudocontinuation
);
9283 int got_new_frame
= klink_pop_cont (sc
);
9284 /* $$RETHINK ME Is this test still needed? Could be just
9288 /* $$IMPROVE ME Instead, a function that governs
9290 if (sc
->new_tracing
)
9292 if(_get_type( sc
->next_func
) == T_NOTRACE
)
9294 sc
->next_func
= notrace_comb( sc
->next_func
);
9298 klink_find_dyn_binding(sc
, K_TRACING
);
9299 /* Now we know the other branch should have been
9301 if( !tracing
|| ( tracing
== K_F
))
9304 /* Enqueue a version that will execute without
9305 tracing. Its descendants will be traced. */
9306 CONTIN_0_RAW (mk_notrace(mk_curried(dcrry_1dotALL
,
9308 mk_notrace(sc
->next_func
))),
9310 switch (_get_type (sc
->next_func
))
9313 putstr (sc
, "\nLoad ");
9317 putstr (sc
, "\nStore ");
9321 putstr (sc
, "\nDecurry ");
9327 /* Find and print current frame depth */
9328 int depth
= curr_frame_depth (sc
->dump
);
9329 char * str
= sc
->strbuff
;
9330 snprintf (str
, STRBUFFSIZE
, "\n%d: ", depth
);
9333 klink_push_dyn_binding (sc
, K_TRACING
, K_F
);
9334 putstr (sc
, "Eval: ");
9335 value
= kernel_print_sexp (sc
,
9336 cons (sc
->next_func
, value
),
9343 value
= kernel_eval_aux (sc
, sc
->next_func
, value
, sc
->envir
);
9347 /* Stop looping if stack is empty. */
9352 /* Otherwise something jumped to a continuation. Get the
9353 value and keep looping. */
9358 /* In case we're called nested in another _klink_cycle, don't
9363 /*_ . Vtable interface */
9364 /* initialization of Klink */
9367 static struct klink_interface vtbl
=
9419 /* $$MOVE ME Later after I separate some headers
9420 This belongs in dynload.c, could be just:
9421 SIG_CHKARRAY(klink_load_ext) = { REF_OPER(is_string), };
9422 DEF_SIMPLE_APPLICATIVE(ps0a1,klink_load_ext,0,ground, "load-extension") {...}
9424 RGSTR(ground
, "load-extension", REF_APPL(klink_load_ext
))
9425 SIG_CHKARRAY(klink_load_ext
) = { REF_OPER(is_string
), };
9426 DEF_SIMPLE_DESTR(klink_load_ext
);
9427 DEF_CFUNC_PSYCNAME(ps0a1
,klink_load_ext
, REF_DESTR(klink_load_ext
),0);
9428 DEF_BOXED_APPLICATIVE(klink_load_ext
, REF_OPER (klink_load_ext
));
9434 /*_ . Initializing Klink */
9435 /*_ , Allocate and initialize */
9438 klink_alloc_init (FILE * in
, FILE * out
)
9440 klink
*sc
= (klink
*) GC_MALLOC (sizeof (klink
));
9441 if (!klink_init (sc
, in
, out
))
9452 /*_ , Initialization without allocation */
9454 klink_init (klink
* sc
, FILE * in
, FILE * out
)
9456 /* Init stack first, just in case something calls _klink_error_1. */
9457 dump_stack_initialize (sc
);
9458 /* Initialize ports early in case something prints. */
9459 /* $$IMPROVE ME Should accept general ports of appropriate in/out. */
9460 klink_set_input_port_file (sc
, in
);
9461 klink_set_output_port_file (sc
, out
);
9464 /* Why do we need this field if there is a static table? */
9469 sc
->new_tracing
= 0;
9472 { oblist
= oblist_initial_value (); }
9475 /* Add the Kernel built-ins */
9476 if(!print_lookup_env
)
9478 print_lookup_env
= K_REGSTRS_TO_ENV(print_lookup_rgsts
);
9480 if(!all_builtins_env
)
9482 all_builtins_env
= K_REGSTRS_TO_ENV(all_builtins
);
9484 if(!typecheck_env_syms
)
9485 { typecheck_env_syms
= K_REGSTRS_TO_ENV(typecheck_syms_rgsts
); }
9488 /** Register objects from hard-coded list. **/
9489 ground_env
= K_REGSTRS_TO_ENV(preregister
);
9490 /* $$TRANSITIONAL Set up special lookup tables related to preregister. */
9491 setup_print_secondary_lookup();
9492 /** Bind certain objects that we make at init time. **/
9493 kernel_define (ground_env
,
9494 mk_symbol ("print-lookup-env"),
9496 kernel_define (unsafe_env
,
9497 mk_symbol ("typecheck-special-syms"),
9498 typecheck_env_syms
);
9500 /** Read some definitions from a prolog **/
9501 /* We need an envir before klink_call, because that defines a
9502 few things. Those bindings are specific to one instance of
9503 the interpreter so they do not belong in anything shared such
9505 /* $$IMPROVE ME Something in the call chain (klink_call?) should
9506 guarantee an environment. Needn't have anything in it to
9508 sc
->envir
= make_new_frame(K_NIL
);
9510 /* Can't easily merge this with klink_load_named_file. Two
9511 difficulties: it uses klink_cycle_restarting while klink_call
9512 uses klink_cycle_no_restart, and here we need to control the
9513 load environment. */
9514 pko p
= port_from_filename (InitFile
, port_file
| port_input
);
9515 if (p
== K_NIL
) { return 0; }
9517 /* We can't use k_get_mod_fm_port to manage parameters because
9518 later we will need the environment to have several parents:
9519 ground, simple, unsafe, possibly more. */
9520 /* Params: `into' = ground environment */
9521 /* We can't share this with the previous frame-making, because
9522 it should not define in the same environment. */
9523 pko params
= make_new_frame(K_NIL
);
9524 kernel_define (params
, mk_symbol ("into"), ground_env
);
9525 pko env
= make_new_frame(ground_env
);
9526 kernel_define (env
, mk_symbol ("module-parameters"), params
);
9527 int retcode
= klink_call(sc
,
9528 REF_OPER(load_from_port
),
9530 if(retcode
) { return 0; }
9532 /* The load will have written various things into ground
9533 environment. sc->envir is unsuitable now because it is this
9534 load's environment. */
9537 assert (is_environment (ground_env
));
9538 sc
->envir
= make_new_frame(ground_env
);
9540 #if 1 /* Transitional. Leave this on for the moment */
9541 /* initialization of global pointers to special symbols */
9542 sc
->QUOTE
= mk_symbol ("quote");
9543 sc
->QQUOTE
= mk_symbol ("quasiquote");
9544 sc
->UNQUOTE
= mk_symbol ("unquote");
9545 sc
->UNQUOTESP
= mk_symbol ("unquote-splicing");
9546 sc
->COLON_HOOK
= mk_symbol ("*colon-hook*");
9547 sc
->SHARP_HOOK
= mk_symbol ("*sharp-hook*");
9554 klink_deinit (klink
* sc
)
9559 /*_ . Using Klink from C */
9560 /*_ , To set ports */
9562 klink_set_input_port_file (klink
* sc
, FILE * fin
)
9564 klink_push_dyn_binding(sc
,K_INPORT
,port_from_file (fin
, port_input
));
9568 klink_set_input_port_string (klink
* sc
, char *start
, char *past_the_end
)
9570 klink_push_dyn_binding(sc
,
9572 port_from_string (start
, past_the_end
, port_input
));
9576 klink_set_output_port_file (klink
* sc
, FILE * fout
)
9578 klink_push_dyn_binding(sc
,K_OUTPORT
,port_from_file (fout
, port_output
));
9582 klink_set_output_port_string (klink
* sc
, char *start
, char *past_the_end
)
9584 klink_push_dyn_binding(sc
,
9586 port_from_string (start
, past_the_end
, port_output
));
9588 /*_ , To set external data */
9590 klink_set_external_data (klink
* sc
, void *p
)
9597 /*_ . Load file (C) */
9600 klink_load_port (klink
* sc
, pko p
, int interactive
)
9609 klink_push_dyn_binding(sc
,K_INPORT
,p
);
9615 REF_OPER (kernel_repl
) :
9616 REF_OPER (kernel_rel
);
9617 klink_cycle_restarting (sc
, combiner
);
9621 /*_ , klink_load_file */
9623 klink_load_file (klink
* sc
, FILE * fin
)
9625 klink_load_port (sc
,
9626 port_from_file (fin
, port_file
| port_input
),
9630 /*_ , klink_load_named_file */
9632 klink_load_named_file (klink
* sc
, FILE * fin
, const char *filename
)
9635 port_from_filename (filename
, port_file
| port_input
),
9639 /*_ . load string (C) */
9642 klink_load_string (klink
* sc
, const char *cmd
)
9645 port_from_string ((char *)cmd
,
9646 (char *)cmd
+ strlen (cmd
),
9647 port_input
| port_string
),
9651 /*_ , Apply combiner */
9652 /* sc is presumed to be already set up.
9653 The final value or error argument is in sc->value.
9654 The return code is duplicated in sc->retcode.
9657 klink_call (klink
* sc
, pko func
, pko args
)
9659 klink_cycle_no_restart (sc
,
9660 mk_curried(dcrry_NdotALL
,args
,func
));
9665 /* This is completely unexercised. */
9668 klink_eval (klink
* sc
, pko obj
)
9670 klink_cycle_no_restart(sc
,
9671 mk_curried(dcrry_2dotALL
,
9672 LIST2(obj
,sc
->envir
),
9673 REF_OPER(kernel_eval
)));
9677 /*_ . Main (if standalone) */
9680 #if defined(__APPLE__) && !defined (OSX)
9684 extern MacTS_main (int argc
, char **argv
);
9686 int argc
= ccommand (&argv
);
9687 MacTS_main (argc
, argv
);
9693 MacTS_main (int argc
, char **argv
)
9697 main (int argc
, char **argv
)
9702 char *file_name
= 0; /* Was InitFile */
9710 if (argc
== 2 && strcmp (argv
[1], "-?") == 0)
9712 printf ("Usage: klink -?\n");
9713 printf ("or: klink [<file1> <file2> ...]\n");
9714 printf ("followed by\n");
9715 printf (" -1 <file> [<arg1> <arg2> ...]\n");
9716 printf (" -c <Kernel commands> [<arg1> <arg2> ...]\n");
9717 printf ("assuming that the executable is named klink.\n");
9718 printf ("Use - as filename for stdin.\n");
9722 /* Make error_continuation semi-safe until it's properly set. */
9723 sc
.error_continuation
= 0;
9724 int i
= setjmp (sc
.pseudocontinuation
);
9727 if (!klink_init (&sc
, stdin
, stdout
))
9729 fprintf (stderr
, "Could not initialize!\n");
9735 fprintf (stderr
, "Kernel error encountered while initializing!\n");
9739 /* $$IMPROVE ME Maybe use get_opts instead. */
9742 /* $$IMPROVE ME Add a principled way of sometimes including
9743 filename defined in environment. Eg getenv
9747 if(!file_name
) { break; }
9748 if (strcmp (file_name
, "-") == 0)
9752 else if (strcmp (file_name
, "-1") == 0 || strcmp (file_name
, "-c") == 0)
9755 /* $$FACTOR ME This is a messy way to distinguish command
9756 string from filename string */
9757 isfile
= (file_name
[1] == '1');
9758 file_name
= *argv
++;
9759 if (strcmp (file_name
, "-") == 0)
9765 fin
= fopen (file_name
, "r");
9768 /* Put remaining command-line args into *args* in envir. */
9769 for (; *argv
; argv
++)
9771 pko value
= mk_string (*argv
);
9772 args
= mcons (value
, args
);
9774 args
= unsafe_v2reverse_in_place (K_NIL
, args
);
9775 /* Instead, use (command-line) as accessor and provide the
9776 whole command line as a list of strings. */
9777 kernel_define (sc
.envir
, mk_symbol ("*args*"), args
);
9782 fin
= fopen (file_name
, "r");
9784 if (isfile
&& fin
== 0)
9786 fprintf (stderr
, "Could not open file %s\n", file_name
);
9792 /* $$IMPROVE ME Use klink_load_named_file, replacing the
9793 file-opening code, so we can report filename */
9794 klink_load_file (&sc
, fin
);
9798 klink_load_string (&sc
, file_name
);
9800 if (!isfile
|| fin
!= stdin
)
9802 if (sc
.retcode
!= 0)
9804 fprintf (stderr
, "Errors encountered reading %s\n",
9817 /* $$MAKE ME CLEANER Quick and dirty for now, we make an
9818 environment for this but let everything else modify ground
9819 env. I'd like to be more correct about that. */
9820 /* Make an interactive environment over ground_env. */
9821 new_frame_in_env (&sc
, sc
.envir
);
9822 klink_load_file (&sc
, stdin
);
9824 retcode
= sc
.retcode
;