?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
klink_call_cfunc now treats promises (but doesn't get them yet)
[Klink.git] / klink.c
blob2e7d11868054e5fe54753d762886785bb6246745
1 /*_. Klink 0.0 */
2 /* Interpreter for the Kernel programming language*/
3 /*_ , Header */
4 /*_ . Credits and License */
5 /*
6 Copyright (C) 2010,2011 Tom Breton (Tehom)
7
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.
12
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.
17
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/>.
20 */
21
22 /*_ . Includes */
23 #define _KLINK_SOURCE
24 #include "klink-private.h"
25 #ifndef WIN32
26 # include <unistd.h>
27 #endif
28 #ifdef WIN32
29 #define snprintf _snprintf
30 #endif
31 #if USE_DL
32 # include "dynload.h"
33 #endif
34 #if USE_MATH
35 # include <math.h>
36 #endif
37
38 #include <limits.h>
39 #include <float.h>
40 #include <ctype.h>
41 #include <assert.h>
42 #include <err.h>
43 #include <gc.h>
44
45 #if USE_STRCASECMP
46 #include <strings.h>
47 # ifndef __APPLE__
48 # define stricmp strcasecmp
49 # endif
50 #endif
51
52 /* Used for documentation purposes, to signal functions in 'interface' */
53 #define INTERFACE
54
55 #include <string.h>
56 #include <stdlib.h>
57
58 #ifdef __APPLE__
59 static int
60 stricmp (const char *s1, const char *s2)
61 {
62 unsigned char c1, c2;
63 do
64 {
65 c1 = tolower (*s1);
66 c2 = tolower (*s2);
67 if (c1 < c2)
68 return -1;
69 else if (c1 > c2)
70 return 1;
71 s1++, s2++;
72 }
73 while (c1 != 0);
74 return 0;
75 }
76 #endif /* __APPLE__ */
77
78 #if USE_STRLWR
79 static const char *
80 strlwr (char *s)
81 {
82 const char *p = s;
83 while (*s)
84 {
85 *s = tolower (*s);
86 s++;
87 }
88 return p;
89 }
90 #endif
91
92 /*_ . Configuration */
93
94 #define banner "Klink 0.0\n"
95
96 #ifndef prompt
97 # define prompt "klink> "
98 #endif
99
100 #ifndef InitFile
101 # define InitFile "init.krn"
102 #endif
103
104 /*_ , Internal declarations */
105 /*_ . Macros */
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
113
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)
118
119 #define FORWARD_DECL_PRED(LINKAGE,C_NAME) \
120 FORWARD_DECL_CFUNC(LINKAGE,b00a1,C_NAME)
121
122 #define FORWARD_DECL_T_PRED(LINKAGE,C_NAME) \
123 LINKAGE kt_boxed_T OPER(C_NAME)
124
125 #define FORWARD_DECL_CHAIN(LINKAGE,C_NAME) \
126 LINKAGE kt_boxed_vector OPER(C_NAME)
127
128 #define FORWARD_DECL_APPLICATIVE(LINKAGE,SUFFIX,C_NAME) \
129 FORWARD_DECL_CFUNC(LINKAGE,SUFFIX,C_NAME); \
130 kt_boxed_encap APPLICATIVE(C_NAME); \
131
132
133 /*_ , WITH_ARGS */
134 /* No noun/number agreement for WITH_1_ARGS because I prefer name
135 regularity. */
136 #define WITH_1_ARGS(A1) \
137 pko A1 = arg1
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 */
150 #define DEF_VEC(T_ENUM, NAME, ARRAY_NAME) \
151 kt_boxed_vector NAME = \
152 { \
153 T_ENUM, \
154 { \
155 sizeof(ARRAY_NAME)/sizeof(ARRAY_NAME[0]), \
156 ARRAY_NAME, \
157 }, \
158 } \
159
160 /*_ , Checking type */
161 /*_ . Certain destructurers and type checks */
162 #define K_ANY REF_OPER(is_any)
163 #define K_NO_TYPE REF_KEY(K_TYCH_NO_TYPE)
164 #define K_ANY_SINGLETON REF_OBJ(_K_any_singleton)
165
166 /*_ . Internal: Arrays to be in typechecks and destructurers */
167 /* Elements of this array should not call Kernel - should be T_NO_K */
168 /* $$IMPROVE ME Check that when registering combiners */
169 #define SIG_CHKARRAY(C_NAME) pko CHKARRAY(C_NAME)[]
170 /*_ . Boxed destructurers */
171 #define REF_DESTR(C_NAME) REF_OBJ(DESTR_NAME(C_NAME))
172 #define DEF_DESTR(NAME,ARRAY_NAME) \
173 DEF_VEC(T_DESTRUCTURE | T_IMMUTABLE | T_NO_K, NAME, ARRAY_NAME)
174
175 #define DEF_SIMPLE_DESTR(C_NAME) \
176 DEF_DESTR(DESTR_NAME(C_NAME), CHKARRAY(C_NAME))
177
178
179 /*_ , BOX macros */
180 /*_ . Allocators */
181 /* Awkward because we both declare stuff and assign stuff. */
182 #define ALLOC_BOX(NAME,T_ENUM,BOXTYPE) \
183 typedef BOXTYPE _TT; \
184 _TT * NAME = GC_MALLOC(sizeof(_TT)); \
185 NAME->type = T_ENUM
186
187 /* ALLOC_BOX_PRESUME defines the following:
188 pbox - a pointer to the box
189 pdata - a pointer to the box's contents
190 */
191 #define ALLOC_BOX_PRESUME(TYPE,T_ENUM) \
192 TYPE * pdata; \
193 ALLOC_BOX(pbox,T_ENUM,BOX_OF(TYPE)); \
194 pdata = &(pbox)->data
195
196 /*_ . Unboxers */
197 /*_ , General */
198 #define WITH_BOX_TYPE(NAME,P) \
199 _kt_tag * NAME = &((kt_boxed_any *)(P))->type;
200
201 /*_ , Raw */
202 /* This could mostly be an inlined function, but it wouldn't know
203 types. */
204 #define WITH_UNBOXED_RAW(P,NAME,TYPE,BOXTYPE) \
205 TYPE * NAME; \
206 { \
207 typedef BOXTYPE _TT; \
208 _TT * _pbox = (_TT *)(P); \
209 NAME = &_pbox->data; \
210 }
211
212 /*_ , Entry points */
213 #define WITH_UNBOXED_UNSAFE(NAME,TYPE,P) \
214 WITH_UNBOXED_RAW(P,NAME,TYPE,BOX_OF(TYPE))
215
216
217 /* WITH_PSYC_UNBOXED defines the following:
218 pdata - a pointer to the box's contents
219 */
220 #define WITH_PSYC_UNBOXED(TYPE,P,T_ENUM,SC) \
221 assert_type(SC,(P),T_ENUM); \
222 WITH_UNBOXED_UNSAFE(pdata,TYPE,P)
223
224 /*_ , Boxes of */
225 /*_ . void */
226 #define REF_KEY(NAME) REF_OBJ(KEY(NAME))
227
228 #define BOX_OF_VOID(NAME) \
229 kt_boxed_void KEY(NAME) = { T_KEY | T_IMMUTABLE }; \
230 pko NAME = REF_KEY(NAME)
231
232 /*_ . Operatives */
233 /* All operatives use this, regardless whether they are cfuncs,
234 curried, etc. */
235 #define REF_OPER(C_NAME) REF_OBJ(OPER(C_NAME))
236
237 /*_ . Cfuncs */
238 #define DEF_CFUNC_RAW(NAME,SUFFIX,C_NAME,DESTR,XTRA_FLAGS) \
239 RGSTR(all-builtins,"C-" #C_NAME, REF_OBJ (NAME)) \
240 kt_boxed_cfunc NAME = \
241 { T_CFUNC | T_IMMUTABLE | XTRA_FLAGS, \
242 {{C_NAME}, klink_ftype_##SUFFIX, DESTR, 0}};
243
244 #define DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME, DESTR,XTRA_FLAGS) \
245 DEF_CFUNC_RAW(OPER(C_NAME),SUFFIX,C_NAME, DESTR,XTRA_FLAGS)
246
247 #define DEF_CFUNC(SUFFIX,C_NAME,DESTR,XTRA_FLAGS) \
248 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
249 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,DESTR,XTRA_FLAGS); \
250 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
251
252 #define DEF_SIMPLE_CFUNC(SUFFIX,C_NAME,XTRA_FLAGS) \
253 DEF_SIMPLE_DESTR(C_NAME); \
254 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
255 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,REF_DESTR(C_NAME),XTRA_FLAGS); \
256 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
257
258 /*_ . Applicatives */
259 #define REF_APPL(C_NAME) REF_OBJ(APPLICATIVE(C_NAME))
260
261 #define DEF_BOXED_APPLICATIVE(C_NAME,FF) \
262 kt_boxed_encap APPLICATIVE (C_NAME) = \
263 { T_ENCAP | T_IMMUTABLE, \
264 {REF_KEY(K_APPLICATIVE), FF}};
265
266 #define DEF_APPLICATIVE_W_DESTR(SUFFIX,C_NAME,DESTR,XTRA_FLAGS,RG,K_NAME) \
267 RGSTR(RG,K_NAME, REF_APPL(C_NAME)) \
268 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
269 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,DESTR,XTRA_FLAGS); \
270 DEF_BOXED_APPLICATIVE(C_NAME, REF_OPER (C_NAME)); \
271 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
272
273 #define DEF_SIMPLE_APPLICATIVE(SUFFIX,C_NAME,XTRA_FLAGS,RG,K_NAME) \
274 RGSTR(RG,K_NAME, REF_APPL(C_NAME)) \
275 DEF_SIMPLE_DESTR(C_NAME); \
276 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
277 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,REF_DESTR(C_NAME),XTRA_FLAGS); \
278 DEF_BOXED_APPLICATIVE(C_NAME, REF_OPER (C_NAME)); \
279 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
280
281 /*_ . Abbreviations for predicates */
282 /* The underlying C function takes the whole value as its sole arg.
283 Above that, in init.krn an applicative wrapper applies it over a
284 list, using `every?'.
285 */
286 #define DEF_SIMPLE_PRED(C_NAME,XTRA_FLAGS,RG,K_NAME) \
287 RGSTR(RG,K_NAME, REF_OPER(C_NAME)) \
288 DEF_CFUNC(b00a1,C_NAME,K_ANY_SINGLETON,XTRA_FLAGS)
289
290 /* The cfunc is there just to be exported for C use. */
291 #define DEF_T_PRED(C_NAME,T_ENUM,RG,K_NAME) \
292 RGSTR(RG,K_NAME, REF_OPER(C_NAME)) \
293 kt_boxed_T OPER(C_NAME) = \
294 { T_TYPEP | T_IMMUTABLE | T_NO_K, {T_ENUM}}; \
295 int C_NAME(pko p) { return is_type(p,T_ENUM); }
296
297
298 /*_ . Curried Functions */
299
300 #define DEF_BOXED_CURRIED(CURRY_NAME,DECURRIER,ARGS,NEXT) \
301 RGSTR(all-builtins,"C-" #CURRY_NAME, REF_OBJ (CURRY_NAME)) \
302 kt_boxed_curried CURRY_NAME = \
303 { T_CURRIED | T_IMMUTABLE, \
304 {DECURRIER, ARGS, NEXT, 0}};
305 /*_ . Pairs */
306 #define DEF_BOXED_PAIR(C_NAME,CAR,CDR) \
307 boxed_vec2 C_NAME = \
308 { T_PAIR | T_IMMUTABLE, {CAR, CDR, }}
309
310 /* $$OBSOLESCENT */
311 #define DEF_LISTSTAR2 DEF_BOXED_PAIR
312
313 #define DEF_LISTSTAR3(C_NAME,A1,A2,A3) \
314 DEF_BOXED_PAIR(C_NAME##__1,A2,A3); \
315 DEF_BOXED_PAIR(C_NAME,A1,REF_OBJ(C_NAME##__1))
316
317 #define DEF_LIST1(C_NAME,A1) DEF_LISTSTAR2(C_NAME,A1, REF_KEY(K_NIL))
318 #define DEF_LIST2(C_NAME,A1,A2) DEF_LISTSTAR3(C_NAME,A1,A2,REF_KEY(K_NIL))
319
320 /*_ , Building objects in C */
321 #define ANON_OBJ( TYPE, X ) \
322 (((BOX_OF( TYPE )[]) { X })[0])
323
324 /* Middle is the same as ANON_OBJ but we can't just use that because
325 of expansion issues */
326 #define ANON_REF( TYPE, X ) \
327 REF_OBJ((((BOX_OF( TYPE )[]) { X })[0]))
328
329 #define PAIR_DEF( CAR, CDR ) \
330 { T_PAIR | T_IMMUTABLE, { CAR, CDR, }, }
331
332 #define ANON_PAIR( CAR, CDR ) \
333 ANON_REF(kt_vec2, PAIR_DEF( CAR, CDR ))
334
335 #define INT_DEF( N ) \
336 { T_NUMBER | T_IMMUTABLE, { 1, { N }, }, }
337
338
339 /*_ , Building lists in C */
340 /*_ . Anonymous lists */
341 /*_ , Dotted */
342 #define ANON_LISTSTAR2(A1, A2) \
343 ANON_PAIR(A1, A2)
344
345 #define ANON_LISTSTAR3(A1, A2, A3) \
346 ANON_PAIR(A1, ANON_LISTSTAR2(A2, A3))
347
348 #define ANON_LISTSTAR4(A1, A2, A3, A4) \
349 ANON_PAIR(A1, ANON_LISTSTAR3(A2, A3, A4))
350
351 /*_ , Undotted */
352 #define ANON_LIST1(A1) \
353 ANON_LISTSTAR2(A1, REF_KEY(K_NIL))
354
355 #define ANON_LIST2(A1, A2) \
356 ANON_PAIR(A1, ANON_LIST1(A2))
357
358 #define ANON_LIST3(A1, A2, A3) \
359 ANON_PAIR(A1, ANON_LIST2(A2, A3))
360
361 #define ANON_LIST4(A1, A2, A3, A4) \
362 ANON_PAIR(A1, ANON_LIST3(A2, A3, A4))
363
364 #define ANON_LIST5(A1, A2, A3, A4, A5) \
365 ANON_PAIR(A1, ANON_LIST4(A2, A3, A4, A5))
366
367 #define ANON_LIST6(A1, A2, A3, A4, A5, A6) \
368 ANON_PAIR(A1, ANON_LIST5(A2, A3, A4, A5, A6))
369
370
371 /*_ . Dynamic lists */
372 /*_ , Dotted */
373 #define LISTSTAR2(A1,A2) \
374 cons (A1, A2)
375 #define LISTSTAR3(A1,A2,A3) \
376 cons (A1, LISTSTAR2(A2, A3))
377
378 /*_ , Undotted */
379
380 #define LIST1(A1) \
381 cons (A1, K_NIL)
382 #define LIST2(A1, A2) \
383 cons (A1, LIST1 (A2))
384 #define LIST3(A1, A2, A3) \
385 cons (A1, LIST2 (A2, A3))
386 #define LIST4(A1, A2, A3, A4) \
387 cons (A1, LIST3 (A2, A3, A4))
388 #define LIST5(A1, A2, A3, A4, A5) \
389 cons (A1, LIST4 (A2, A3, A4, A5))
390 #define LIST6(A1, A2, A3, A4, A5, A6) \
391 cons (A1, LIST5 (A2, A3, A4, A5, A6))
392
393 /*_ , Kernel continuation macros */
394 /*_ . W/o decurrying */
395 #define CONTIN_0_RAW(C_NAME,SC) \
396 klink_push_cont((SC), (C_NAME))
397 #define CONTIN_0(OPER_NAME,SC) \
398 klink_push_cont((SC), REF_OPER (OPER_NAME))
399
400 /*_ . Dotting */
401 /* The use of REF_OPER requires these to be macros. */
402
403 #define CONTIN_1R(DECURRIER,C_NAME,SC,ARGS) \
404 klink_push_cont((SC), \
405 mk_curried(DECURRIER, ARGS, REF_OPER (C_NAME)))
406
407 #define CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,ARG2) \
408 CONTIN_1R(DECURRIER,C_NAME,SC,cons(ARG1,ARG2))
409
410 #define CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3) \
411 CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,cons(ARG2,ARG3))
412
413 #define CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4) \
414 CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,cons(ARG3,ARG4))
415
416 #define CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5) \
417 CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,cons(ARG4,ARG5))
418
419 #define CONTIN_6R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5,ARG6) \
420 CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,cons(ARG5,ARG6))
421
422
423 /*_ . Straight */
424 #define CONTIN_1(DECURRIER,C_NAME,SC,ARG1) \
425 CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,K_NIL)
426
427 #define CONTIN_2(DECURRIER,C_NAME,SC,ARG1,ARG2) \
428 CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,K_NIL)
429
430 #define CONTIN_3(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3) \
431 CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,K_NIL)
432
433 #define CONTIN_4(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4) \
434 CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,K_NIL)
435
436 #define CONTIN_5(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5) \
437 CONTIN_6R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5,K_NIL)
438
439 /*_ , C to bool */
440 #define kernel_bool(tf) ((tf) ? K_T : K_F)
441
442 /*_ , Control macros */
443
444 /* These never return because _klink_error_1 longjmps. */
445 /* $$IMPROVE ME If GCC is used or C99 is available, use __func__ as the function name. */
446 #define KERNEL_ERROR_1(sc,s, a) { _klink_error_1(sc,s,a); return 0; }
447 #define KERNEL_ERROR_0(sc,s) { _klink_error_1(sc,s,0); return 0; }
448
449 /*_ . Enumerations */
450 /*_ , The port types & flags */
451
452 enum klink_port_kind
453 {
454 port_free = 0,
455 port_file = 1,
456 port_string = 2,
457 port_srfi6 = 4,
458 port_input = 16,
459 port_output = 32,
460 port_saw_EOF = 64,
461 };
462
463 /*_ , Tokens */
464
465 typedef enum klink_token
466 {
467 TOK_LPAREN,
468 TOK_RPAREN,
469 TOK_DOT,
470 TOK_ATOM,
471 TOK_QUOTE,
472 TOK_COMMENT,
473 TOK_DQUOTE,
474 TOK_BQUOTE,
475 TOK_COMMA,
476 TOK_ATMARK,
477 TOK_SHARP,
478 TOK_SHARP_CONST,
479 TOK_VEC,
480
481 TOK_EOF = -1,
482 } token_t;
483 /*_ , List metrics */
484 typedef enum
485 {
486 lm_num_pairs,
487 lm_num_nils,
488 lm_acyc_len,
489 lm_cyc_len,
490 lm_max,
491 } lm_index;
492 typedef int int4[lm_max];
493
494 /*_ . Struct definitions */
495
496 /*_ , FF */
497 typedef BOX_OF (kt_cfunc)
498 kt_boxed_cfunc;
499
500 /*_ , Encap */
501 typedef
502 struct
503 {
504 /* Object identity lets us compare instances. */
505 pko type;
506 pko value;
507 } kt_encap;
508
509 typedef BOX_OF (kt_encap)
510 kt_boxed_encap;
511
512 /*_ , Curried calls */
513
514 typedef pko (* decurrier_f) (klink * sc, pko args, pko value);
515
516 typedef
517 struct
518 {
519 decurrier_f decurrier;
520 pko args;
521 pko next;
522 pko argcheck;
523 } kt_curried;
524
525 typedef BOX_OF (kt_curried)
526 kt_boxed_curried;
527
528 /*_ , T_typep calls */
529 /*_ . Structures */
530 typedef struct
531 {
532 _kt_tag T_tag;
533 } typep_t;
534
535 typedef BOX_OF(typep_t)
536 kt_boxed_T;
537
538 /*_ , Ports */
539
540 typedef struct port
541 {
542 unsigned char kind;
543 union
544 {
545 struct
546 {
547 FILE *file;
548 int closeit;
549 #if SHOW_ERROR_LINE
550 int curr_line;
551 char *filename;
552 #endif
553 } stdio;
554 struct
555 {
556 char *start;
557 char *past_the_end;
558 char *curr;
559 } string;
560 } rep;
561 } port;
562 /*_ , Vectors */
563 typedef struct
564 {
565 long int len;
566 pko * els;
567 } kt_vector;
568
569 typedef BOX_OF(kt_vector)
570 kt_boxed_vector;
571
572 /*_ . Signatures */
573 /*_ , Initialization */
574 static void klink_setup_error_cont (klink * sc);
575 static void klink_cycle_restarting (klink * sc, pko combiner);
576 static int klink_cycle_no_restart (klink * sc, pko combiner);
577 static void _klink_cycle (klink * sc);
578
579
580 /*_ , Error handling */
581 static void _klink_error_1 (klink * sc, const char *s, pko a);
582 /*_ . Stack control */
583 static int klink_pop_cont (klink * sc);
584
585 /*_ , Evaluation */
586 static pko klink_call_cfunc (klink * sc, pko functor, pko env, pko args);
587 static pko
588 k_resume_to_cfunc (klink * sc, pko functor, pko value);
589 /*_ . load */
590 extern pko
591 mk_load_ix (int x, int y);
592 extern pko
593 mk_load (pko data);
594 /*_ . store */
595 extern pko
596 mk_store (pko data, int depth);
597 /*_ . curried */
598 /* $$DEPRECATED */
599 static pko
600 call_curried(klink * sc, pko curried, pko value);
601
602 /*_ , Top level operatives */
603 FORWARD_DECL_APPLICATIVE(static,ps0a0,kernel_repl);
604 FORWARD_DECL_APPLICATIVE(static,ps0a0,kernel_rel);
605 FORWARD_DECL_APPLICATIVE(static,ps0a1,kernel_internal_eval);
606
607 /*_ , Oblist */
608 static INLINE pko oblist_find_by_name (const char *name);
609 static pko oblist_add_by_name (const char *name);
610
611 /*_ , Numbers */
612 static pko mk_number (num n);
613 /*_ . Operations */
614 static num num_add (num a, num b);
615 static num num_mul (num a, num b);
616 static num num_div (num a, num b);
617 static num num_intdiv (num a, num b);
618 static num num_sub (num a, num b);
619 static num num_rem (num a, num b);
620 static num num_mod (num a, num b);
621 static int num_eq (num a, num b);
622 static int num_gt (num a, num b);
623 static int num_ge (num a, num b);
624 static int num_lt (num a, num b);
625 static int num_le (num a, num b);
626
627 #if USE_MATH
628 static double round_per_R5RS (double x);
629 #endif
630
631 /*_ , Lists and vectors */
632 FORWARD_DECL_PRED (extern, is_finite_list);
633 FORWARD_DECL_PRED (extern, is_countable_list);
634 extern int list_length (pko a);
635 static pko reverse (klink * sc, pko a);
636 static pko unsafe_v2reverse_in_place (pko term, pko list);
637 static pko append (klink * sc, pko a, pko b);
638
639 static pko alloc_basvector (int len, _kt_tag t_enum);
640 static void unsafe_basvector_fill (pko vec, pko obj);
641
642 static pko mk_vector (int len, pko fill);
643 INTERFACE static void fill_vector (pko vec, pko obj);
644 INTERFACE static pko vector_elem (pko vec, int ielem);
645 INTERFACE static void set_vector_elem (pko vec, int ielem, pko a);
646 INTERFACE static int vector_len (pko vec);
647 extern void
648 get_list_metrics_aux (pko a, int4 presults);
649
650 extern pko
651 k_counted_map_car(klink * sc, int count, pko list, _kt_tag t_enum);
652 extern pko
653 k_counted_map_cdr(klink * sc, int count, pko list, _kt_tag t_enum);
654
655 /*_ , Ports */
656 static pko port_from_filename (const char *fn, int prop);
657 static pko port_from_file (FILE *, int prop);
658 static pko port_from_string (char *start, char *past_the_end, int prop);
659 static void port_close (pko p, int flag);
660 static void port_finalize_file(GC_PTR obj, GC_PTR client_data);
661 static port *port_rep_from_filename (const char *fn, int prop);
662 static port *port_rep_from_file (FILE *, int prop);
663 static port *port_rep_from_string (char *start, char *past_the_end, int prop);
664 static void port_close_port (port * pt, int flag);
665 INLINE port * portvalue (pko p);
666 static int basic_inchar (port * pt);
667 static int inchar (port *pt);
668 static void backchar (port * pt, int c);
669 /*_ , Typechecks */
670 FORWARD_DECL_APPLICATIVE (extern,ps0a1, mk_typecheck);
671 FORWARD_DECL_APPLICATIVE (extern,ps0a1, mk_destructurer);
672 FORWARD_DECL_CFUNC (extern, ps0a4, destructure_resume);
673 FORWARD_DECL_PRED (extern, is_any);
674 FORWARD_DECL_T_PRED (extern, is_environment);
675 FORWARD_DECL_PRED (extern, is_integer);
676 /*_ , Promises */
677 FORWARD_DECL_CFUNC (extern,ps0a2,handle_promise_result);
678 FORWARD_DECL_CFUNC (extern, ps0a1, mk_promise_lazy);
679 FORWARD_DECL_APPLICATIVE (extern, ps0a1, force);
680 /*_ , About encapsulation */
681 FORWARD_DECL_CFUNC (static,b00a2, is_encap);
682 FORWARD_DECL_CFUNC (static,p00a2, mk_encap);
683 FORWARD_DECL_CFUNC (static,ps0a2, unencap);
684 FORWARD_DECL_APPLICATIVE (extern,p00a0, mk_encapsulation_type);
685
686 /*_ , About combiners per se */
687 FORWARD_DECL_PRED(extern,is_combiner);
688 /*_ , About operatives */
689 FORWARD_DECL_PRED(extern,is_operative);
690
691 /*_ , About applicatives */
692
693 FORWARD_DECL_PRED(extern,is_applicative);
694 FORWARD_DECL_APPLICATIVE(extern,p00a1,wrap);
695 FORWARD_DECL_APPLICATIVE(extern,ps0a1,unwrap);
696 FORWARD_DECL_APPLICATIVE(extern,p00a1,unwrap_all);
697
698 /*_ , About currying */
699 static INLINE int
700 is_curried (pko p);
701
702 /*_ . Decurriers */
703 static pko dcrry_2A01VLL (klink * sc, pko args, pko value);
704 static pko dcrry_3A01dotVLL (klink * sc, pko args, pko value);
705 static pko dcrry_2CA01VLLA02 (klink * sc, pko args, pko value);
706 /* May not be needed */
707 static pko dcrry_3A01A02VLL (klink * sc, pko args, pko value);
708 static pko dcrry_2ALLVLL (klink * sc, pko args, pko value);
709 static pko dcrry_2ALLV01 (klink * sc, pko args, pko value);
710
711 static pko dcrry_NdotALL (klink * sc, pko args, pko value);
712 #define dcrry_1A01 dcrry_NdotALL
713 #define dcrry_1dotALL dcrry_NdotALL
714 #define dcrry_2dotALL dcrry_NdotALL
715 #define dcrry_3dotALL dcrry_NdotALL
716 #define dcrry_4dotALL dcrry_NdotALL
717
718 static pko dcrry_1ALL (klink * sc, pko args, pko value);
719
720 static pko dcrry_5ALLdotVLL (klink * sc, pko args, pko value);
721 #define dcrry_3ALLdotVLL dcrry_5ALLdotVLL
722
723 static pko dcrry_NVLLdotALL (klink * sc, pko args, pko value);
724 #define dcrry_2VLLdotALL dcrry_NVLLdotALL
725 #define dcrry_3VLLdotALL dcrry_NVLLdotALL
726 #define dcrry_4VLLdotALL dcrry_NVLLdotALL
727 #define dcrry_5VLLdotALL dcrry_NVLLdotALL
728
729 static pko dcrry_1VLL (klink * sc, pko args, pko value);
730 static pko dcrry_NCVLLA01dotAX1 (klink * sc, pko args, pko value);
731 #define dcrry_2CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
732 #define dcrry_3CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
733 #define dcrry_4CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
734 #define dcrry_5CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
735 /*_ . Associated */
736 FORWARD_DECL_CFUNC(static,ps0a4,values_pair);
737
738
739 /*_ , Of Kernel evaluation */
740 /*_ . Public functions */
741 FORWARD_DECL_APPLICATIVE(extern,ps0a2,kernel_eval);
742 FORWARD_DECL_CFUNC (extern,ps0a3, vau_1);
743 /*_ . Other signatures */
744 FORWARD_DECL_APPLICATIVE(static,ps0a3,kernel_eval_aux);
745 FORWARD_DECL_APPLICATIVE(static,ps0a3,kernel_mapeval);
746 FORWARD_DECL_APPLICATIVE(static,ps0a3, kernel_mapand_aux);
747 FORWARD_DECL_APPLICATIVE(extern,ps0a2, kernel_mapand);
748 FORWARD_DECL_APPLICATIVE(static,ps0a5,eval_vau);
749
750 /*_ , Reading */
751
752 FORWARD_DECL_APPLICATIVE(static,ps0a0,kernel_read_internal);
753 FORWARD_DECL_CFUNC(extern,ps0a0,kernel_read_sexp);
754 FORWARD_DECL_CFUNC(static,ps0a2,kernel_read_list);
755 FORWARD_DECL_CFUNC(static,ps0a2,kernel_treat_dotted_list);
756 FORWARD_DECL_CFUNC(static,ps0a1,kernel_treat_qquoted_vec);
757
758 static INLINE int is_one_of (char *s, int c);
759 static long binary_decode (const char *s);
760 static char *readstr_upto (klink * sc, char *delim);
761 static pko readstrexp (klink * sc);
762 static INLINE int skipspace (klink * sc);
763 static int token (klink * sc);
764 static pko mk_atom (klink * sc, char *q);
765 static pko mk_sharp_const (char *name);
766
767 /*_ , Printing */
768 /* $$IMPROVE ME These should mostly be just operatives. */
769 FORWARD_DECL_APPLICATIVE(static,ps0a2,kernel_print_sexp);
770 FORWARD_DECL_APPLICATIVE(static,ps0a3,kernel_print_sexp_aux);
771 FORWARD_DECL_APPLICATIVE(static,ps0a3,kernel_print_list);
772 FORWARD_DECL_APPLICATIVE(static,ps0a4,kernel_print_vec_from);
773 static kt_boxed_curried k_print_terminate_list;
774
775 static void printslashstring (klink * sc, char *s, int len);
776 static void atom2str (klink * sc, pko l, char **pp, int *plen);
777 static void printatom (klink * sc, pko l);
778
779 /*_ , Stack & continuations */
780 /*_ . Continuations */
781 static pko mk_continuation (_kt_spagstack d);
782 static void klink_push_cont (klink * sc, pko combiner);
783 static _kt_spagstack
784 klink_push_cont_aux (_kt_spagstack old_frame, pko ff, pko env);
785 FORWARD_DECL_APPLICATIVE(extern,p00a1,continuation_to_applicative);
786 FORWARD_DECL_CFUNC(static,vs0a2,invoke_continuation);
787 FORWARD_DECL_CFUNC(static,ps0a2,continue_abnormally);
788 static _kt_spagstack special_dynxtnt
789 (_kt_spagstack outer, _kt_spagstack prox_dest, pko envir);
790 static _kt_spagstack
791 cont_dump (pko p);
792
793 /*_ . Dynamic bindings */
794 static void klink_push_dyn_binding (klink * sc, pko id, pko value);
795 static pko klink_find_dyn_binding(klink * sc, pko id);
796 /*_ . Profiling */
797 struct stack_profiling;
798 static void
799 k_profiling_done_frame(klink * sc, struct stack_profiling * profile);
800 /*_ . Stack args */
801 static pko
802 get_nth_arg( _kt_spagstack frame, int n );
803 static void
804 push_arg (klink * sc, pko value);
805
806 /*_ , Environment and defining */
807 FORWARD_DECL_CFUNC(static,vs0a3,kernel_define_tree);
808 FORWARD_DECL_CFUNC(extern,p00a3,kernel_define);
809 FORWARD_DECL_CFUNC(extern,ps0a2,eval_define);
810 FORWARD_DECL_CFUNC(extern,ps0a3,set);
811 FORWARD_DECL_CFUNC(static,ps0a4,set_aux);
812
813 static pko find_slot_in_env (pko env, pko sym, int all);
814 static INLINE pko slot_value_in_env (pko slot);
815 static INLINE void set_slot_in_env (pko slot, pko value);
816 static pko
817 reverse_find_slot_in_env_aux (pko env, pko value);
818 /*_ . Standard environment */
819 FORWARD_DECL_CFUNC(extern,p00a0, mk_std_environment);
820 FORWARD_DECL_APPLICATIVE (extern,ps0a0, get_current_environment);
821 /*_ , Misc kernel functions */
822
823 FORWARD_DECL_CFUNC(extern,ps0a1,arg1);
824 FORWARD_DECL_APPLICATIVE(extern,ps0a1,val2val)
825
826 /*_ , Error functions */
827 FORWARD_DECL_CFUNC(static,ps0a1,kernel_err);
828 FORWARD_DECL_CFUNC(static,ps0a1,kernel_err_x);
829
830 /*_ , For DL if present */
831 #if USE_DL
832 FORWARD_DECL_APPLICATIVE(extern,ps0a1,klink_load_ext);
833 #endif
834
835 /*_ , Symbols */
836 static pko mk_symbol_obj (const char *name);
837
838 /*_ , Strings */
839 static char *store_string (int len, const char *str, char fill);
840
841 /*_ . Object declarations */
842 /*_ , Keys */
843 /* These objects are declared here because some macros use them, but
844 should not be directly used. */
845 /* $$IMPROVE ME Somehow hide these better without hiding it from the
846 applicative & destructure macros. */
847 kt_boxed_void KEY(K_APPLICATIVE);
848 kt_boxed_void KEY(K_NIL);
849 /*_ , Typechecks */
850 kt_boxed_vector _K_any_singleton;
851 /*_ , Pointers to base environments */
852 static pko print_lookup_env;
853 static pko all_builtins_env;
854 static pko ground_env;
855 static pko typecheck_env_syms;
856 /* Caches */
857 static pko print_lookup_unwraps;
858 static pko print_lookup_to_xary;
859
860 /*_ , Body */
861 /*_ . Low-level treating T-types */
862 /*_ , Type itself */
863 /*_ . _get_type */
864 INLINE int
865 _get_type (pko p)
866 {
867 WITH_BOX_TYPE(ptype,p);
868 return *ptype & T_MASKTYPE;
869 }
870
871 /*_ . is_type */
872 INLINE int
873 is_type (pko p, int T_index)
874 {
875 return _get_type (p) == T_index;
876 }
877 /*_ . type_err_string */
878 const char *
879 type_err_string(_kt_tag t_enum)
880 {
881 switch(t_enum)
882 {
883 case T_STRING:
884 return "Must be a string";
885 case T_NUMBER:
886 return "Must be a number";
887 case T_SYMBOL:
888 return "Must be a symbol";
889 case T_PAIR:
890 return "Must be a pair";
891 case T_CHARACTER:
892 return "Must be a character";
893 case T_PORT:
894 return "Must be a port";
895 case T_ENCAP:
896 return "Must be an encapsulation";
897 case T_CONTINUATION:
898 return "Must be a continuation";
899 case T_ENV_FRAME:
900 return "Must be an environment";
901 case T_RECURRENCES:
902 return "Must be a recurrence table";
903 case T_RECUR_TRACKER:
904 return "Must be a recurrence tracker";
905 default:
906 /* Left out types that shouldn't be distinguished in Kernel. */
907 return "Error message for this type needs to be coded";
908 }
909 }
910 /*_ . assert_type */
911 /* If sc is given, it's a assertion making a Kernel error, otherwise
912 it's a C assertion. */
913 INLINE void
914 assert_type (sc_or_null sc, pko p, _kt_tag t_enum)
915 {
916 if(sc && (_get_type(p) != (t_enum)))
917 {
918 const char * err_msg = type_err_string(t_enum);
919 _klink_error_1(sc,err_msg,p);
920 return; /* NOTREACHED */
921 }
922 else
923 { assert (_get_type(p) == (t_enum)); }
924 }
925
926 /*_ , Mutability */
927
928 INTERFACE INLINE int
929 is_immutable (pko p)
930 {
931 WITH_BOX_TYPE(ptype,p);
932 return *ptype & T_IMMUTABLE;
933 }
934
935 INTERFACE INLINE void
936 setimmutable (pko p)
937 {
938 WITH_BOX_TYPE(ptype,p);
939 *ptype |= T_IMMUTABLE;
940 }
941
942 /* If sc is given, it's a assertion making a Kernel error, otherwise
943 it's a C assertion. */
944 INLINE void
945 assert_mutable (sc_or_null sc, pko p)
946 {
947 WITH_BOX_TYPE(ptype,p);
948 if(sc && (*ptype & T_IMMUTABLE))
949 {
950 _klink_error_1(sc,"Attempt to mutate immutable object",p);
951 return;
952 }
953 else
954 { assert(!(*ptype & T_IMMUTABLE)); }
955 }
956
957 #define DEBUG_assert_mutable assert_mutable
958
959 /*_ , No-call-Kernel */
960 inline int
961 no_call_k(pko p)
962 {
963 WITH_BOX_TYPE(ptype,p);
964 return *ptype & T_NO_K;
965 }
966 /*_ , eq? */
967 SIG_CHKARRAY(eqp) = { K_ANY, K_ANY, };
968 DEF_SIMPLE_APPLICATIVE(p00a2,eqp,T_NO_K,ground,"eq?")
969 {
970 WITH_2_ARGS(a,b);
971 return kernel_bool(a == b);
972 }
973 /*_ . Low-level object types */
974 /*_ , vec2 (Low lists) */
975 /*_ . Struct */
976 typedef struct
977 {
978 pko _car;
979 pko _cdr;
980 } kt_vec2;
981 typedef BOX_OF(kt_vec2) boxed_vec2;
982
983 /*_ . Type assert */
984 /* $$IMPROVE ME Disable this if DEBUG_LEVEL is low */
985 void assert_T_is_v2(_kt_tag t_enum)
986 {
987 t_enum &= T_MASKTYPE;
988 assert(
989 t_enum == T_PAIR ||
990 t_enum == T_ENV_PAIR ||
991 t_enum == T_ENV_FRAME ||
992 t_enum == T_PROMISE
993 );
994 }
995
996 /*_ . Create */
997 pko
998 v2cons (_kt_tag t_enum, pko a, pko b)
999 {
1000 ALLOC_BOX_PRESUME (kt_vec2, t_enum);
1001 pbox->data._car = a;
1002 pbox->data._cdr = b;
1003 return PTR2PKO(pbox);
1004 }
1005
1006 /*_ . Unsafe operations (Typechecks can be disabled) */
1007 INLINE pko
1008 unsafe_v2car (pko p)
1009 {
1010 assert_T_is_v2(_get_type(p));
1011 WITH_UNBOXED_UNSAFE(pdata,kt_vec2,p);
1012 return pdata->_car;
1013 }
1014
1015 INLINE pko
1016 unsafe_v2cdr (pko p)
1017 {
1018 assert_T_is_v2(_get_type(p));
1019 WITH_UNBOXED_UNSAFE(pdata,kt_vec2,p);
1020 return pdata->_cdr;
1021 }
1022
1023 INLINE void
1024 unsafe_v2set_car (pko p, pko q)
1025 {
1026 assert_T_is_v2(_get_type(p));
1027 DEBUG_assert_mutable(0,p);
1028 WITH_UNBOXED_UNSAFE(pdata,kt_vec2,p);
1029 pdata->_car = q;
1030 return;
1031 }
1032
1033 INLINE void
1034 unsafe_v2set_cdr (pko p, pko q)
1035 {
1036 assert_T_is_v2(_get_type(p));
1037 DEBUG_assert_mutable(0,p);
1038 WITH_UNBOXED_UNSAFE(pdata,kt_vec2,p);
1039 pdata->_cdr = q;
1040 return;
1041 }
1042
1043 /*_ . Checked operations */
1044 pko
1045 v2car (sc_or_null err_reporter, _kt_tag t_enum, pko p)
1046 {
1047 assert_type(err_reporter,p,t_enum);
1048 return unsafe_v2car(p);
1049 }
1050
1051 pko
1052 v2cdr (sc_or_null err_reporter, _kt_tag t_enum, pko p)
1053 {
1054 assert_type(err_reporter,p,t_enum);
1055 return unsafe_v2cdr(p);
1056 }
1057
1058 void
1059 v2set_car (sc_or_null err_reporter, _kt_tag t_enum, pko p, pko q)
1060 {
1061 assert_type(err_reporter,p,t_enum);
1062 assert_mutable(err_reporter,p);
1063 unsafe_v2set_car(p,q);
1064 return;
1065 }
1066
1067 void
1068 v2set_cdr (sc_or_null err_reporter, _kt_tag t_enum, pko p, pko q)
1069 {
1070 assert_type(err_reporter,p,t_enum);
1071 assert_mutable(err_reporter,p);
1072 unsafe_v2set_cdr(p,q);
1073 return;
1074 }
1075
1076 /*_ . "Psychic" macros */
1077 #define WITH_V2(T_ENUM) \
1078 _kt_tag _t_enum = T_ENUM; \
1079 assert_T_is_v2(_t_enum)
1080
1081 /* These expect WITH_REPORTER and WITH_V2 to be used in scope. */
1082 #define PSYC_v2cons(A,B) v2cons (_t_enum, (A), (B))
1083 #define PSYC_v2car(X) v2car (_err_reporter, _t_enum, (X))
1084 #define PSYC_v2cdr(X) v2cdr (_err_reporter, _t_enum, (X))
1085 #define PSYC_v2set_car(A,B) v2set_car (_err_reporter, _t_enum, (A), (B))
1086 #define PSYC_v2set_cdr(A,B) v2set_cdr (_err_reporter, _t_enum, (A), (B))
1087
1088 /*_ . Container macros */
1089
1090 /* This expects _EXPLORE_FUNC to be defined as a macro taking OBJ,
1091 inspecting it but not mutating it. */
1092 #define EXPLORE_v2(OBJ) \
1093 { \
1094 WITH_UNBOXED_UNSAFE(pdata,kt_vec2,OBJ); \
1095 _EXPLORE_FUNC(pdata->_car); \
1096 _EXPLORE_FUNC(pdata->_cdr); \
1097 }
1098
1099 /* #define _EXPLORE_FUNC(X) trace_tree_cycles(X, p_cycles_data) */
1100
1101 /*_ . Low list operations */
1102 /*_ , v2list_star */
1103 pko v2list_star(sc_or_null sc, pko d, _kt_tag t_enum)
1104 {
1105 WITH_REPORTER(sc);
1106 WITH_V2(t_enum);
1107 pko p, q;
1108 pko cdr_d = PSYC_v2cdr (d);
1109 if (cdr_d == K_NIL)
1110 {
1111 return PSYC_v2car (d);
1112 }
1113 p = PSYC_v2cons (PSYC_v2car (d), cdr_d);
1114 q = p;
1115
1116 while (PSYC_v2cdr (PSYC_v2cdr (p)) != K_NIL)
1117 {
1118 pko cdr_p = PSYC_v2cdr (p);
1119 d = PSYC_v2cons (PSYC_v2car (p), cdr_p);
1120 if (PSYC_v2cdr (cdr_p) != K_NIL)
1121 {
1122 p = PSYC_v2cdr (d);
1123 }
1124 }
1125 PSYC_v2set_cdr (p, PSYC_v2car (PSYC_v2cdr (p)));
1126 return q;
1127 }
1128
1129 /*_ , reverse list -- produce new list */
1130 pko v2reverse(pko a, _kt_tag t_enum)
1131 {
1132 WITH_V2(t_enum);
1133 pko p = K_NIL;
1134 for (; is_type (a, t_enum); a = unsafe_v2cdr (a))
1135 {
1136 p = v2cons (t_enum, unsafe_v2car (a), p);
1137 }
1138 return (p);
1139 }
1140
1141 /*_ , reverse list -- in-place (Not typechecked) */
1142 /* last_cdr will be the tail of the resulting list. It is usually
1143 K_NIL.
1144
1145 list is the list to be reversed. Caller guarantees that list is a
1146 proper list, each link being either some type of vec2 or K_NIL.
1147 */
1148 static pko
1149 unsafe_v2reverse_in_place (pko last_cdr, pko list)
1150 {
1151 pko p = list, result = last_cdr;
1152 while (p != K_NIL)
1153 {
1154 pko scratch = unsafe_v2cdr (p);
1155 unsafe_v2set_cdr (p, result);
1156 result = p;
1157 p = scratch;
1158 }
1159 return (result);
1160 }
1161 /*_ , append list -- produce new list */
1162 pko v2append(sc_or_null err_reporter, pko a, pko b, _kt_tag t_enum)
1163 {
1164 WITH_V2(t_enum);
1165 if (a == K_NIL)
1166 { return b; }
1167 else
1168 {
1169 a = v2reverse (a, t_enum);
1170 /* Correct even if b is nil or a non-list. */
1171 return unsafe_v2reverse_in_place(b, a);
1172 }
1173 }
1174
1175
1176 /*_ , basvectors (Low vectors) */
1177 /*_ . Struct */
1178 /* Above so it can be visible to early typecheck declarations. */
1179 /*_ . Type assert */
1180 void assert_T_is_basvector(_kt_tag t_enum)
1181 {
1182 t_enum &= T_MASKTYPE;
1183 assert(
1184 t_enum == T_VECTOR ||
1185 t_enum == T_TYPECHECK ||
1186 t_enum == T_DESTRUCTURE
1187 );
1188 }
1189
1190 /*_ . Create */
1191 /*_ , alloc_basvector */
1192 static pko
1193 alloc_basvector (int len, _kt_tag t_enum)
1194 {
1195 assert_T_is_basvector(t_enum);
1196 ALLOC_BOX_PRESUME(kt_vector, t_enum);
1197 pbox->data.len = len;
1198 pbox->data.els = (pko *)GC_MALLOC ((sizeof (pko) * len));
1199 /* We don't fill this vector, we expect it to be filled later. */
1200 return PTR2PKO(pbox);
1201 }
1202 /*_ , mk_basvector_w_args */
1203 static pko
1204 mk_basvector_w_args(klink * sc, pko args, _kt_tag t_enum)
1205 {
1206 WITH_REPORTER(sc);
1207 assert_T_is_basvector(t_enum);
1208 int4 metrics;
1209 get_list_metrics_aux(args, metrics);
1210 if (metrics[lm_num_nils] != 1)
1211 {
1212 KERNEL_ERROR_1 (sc, "mk_basvector_w_args: not a proper list:", args);
1213 }
1214 int len = metrics[lm_acyc_len];
1215 pko vec = alloc_basvector(len, t_enum);
1216 WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1217 int i;
1218 pko x;
1219 for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
1220 {
1221 pdata->els[i] = car (x);
1222 }
1223 return vec;
1224 }
1225 /*_ , mk_filled_basvector */
1226 pko
1227 mk_filled_basvector(int len, pko fill, _kt_tag t_enum)
1228 {
1229 assert_T_is_basvector(t_enum);
1230 pko vec = alloc_basvector(len, t_enum);
1231 unsafe_basvector_fill (vec, fill);
1232 return vec;
1233 }
1234 /*_ , mk_basvector_from_array */
1235 pko
1236 mk_basvector_from_array(int len, pko * array, _kt_tag t_enum)
1237 {
1238 assert_T_is_basvector(t_enum);
1239 pko vec = alloc_basvector(len, t_enum);
1240 WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1241 int i;
1242 for (i = 0; i < len; i++)
1243 {
1244 pdata->els [i] = array [i];
1245 }
1246 return vec;
1247 }
1248 /*_ , mk_foresliced_basvector */
1249 pko
1250 mk_foresliced_basvector (pko vec, int excess, _kt_tag t_enum)
1251 {
1252 WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1253 const int len = pdata->len;
1254 assert (len >= excess);
1255 const int remnant_len = len - excess;
1256 return mk_basvector_from_array (remnant_len,
1257 pdata->els + excess,
1258 t_enum);
1259 }
1260 /*_ . Unsafe operations (Typechecks can be disabled) */
1261 /*_ , unsafe_basvector_fill */
1262 static void
1263 unsafe_basvector_fill (pko vec, pko obj)
1264 {
1265 assert_T_is_basvector(_get_type(vec));
1266 assert_mutable(0,vec);
1267 WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1268 {
1269 int i;
1270 const int num = pdata->len;
1271
1272 for (i = 0; i < num; i++)
1273 { pdata->els[i] = obj; }
1274 }
1275 }
1276 /*_ , basvector_len */
1277 static int
1278 basvector_len (pko vec)
1279 {
1280 assert_T_is_basvector(_get_type(vec));
1281 WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1282 return pdata->len;
1283 }
1284
1285 /*_ , basvector_elem */
1286 static pko
1287 basvector_elem (pko vec, int ielem)
1288 {
1289 assert_T_is_basvector(_get_type(vec));
1290 WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1291 assert(ielem >= 0);
1292 assert(ielem < pdata->len);
1293 return pdata->els[ielem];
1294 }
1295
1296 /*_ , basvector_set_elem */
1297 static void
1298 basvector_set_elem (pko vec, int ielem, pko a)
1299 {
1300 assert_T_is_basvector(_get_type(vec));
1301 assert_mutable(0,vec);
1302 WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1303 assert(ielem >= 0);
1304 assert(ielem < pdata->len);
1305 pdata->els[ielem] = a;
1306 return;
1307 }
1308 /*_ , basvector_fill_array */
1309 static void
1310 basvector_fill_array(pko vec, int max_len, pko * array)
1311 {
1312 assert_T_is_basvector(_get_type(vec));
1313 WITH_UNBOXED_UNSAFE (p_vec, kt_vector, vec);
1314 int count = p_vec->len;
1315 assert (count < max_len);
1316 int i;
1317 for (i = 0; i < count; i++)
1318 {
1319 array [i] = p_vec->els [i];
1320 }
1321 return;
1322 }
1323 /*_ . Checked operations */
1324 /*_ , Basic strings (Low strings) */
1325 /*_ . Struct kt_string */
1326
1327 typedef struct
1328 {
1329 char *_svalue;
1330 int _length;
1331 } kt_string;
1332
1333 /*_ . Get parts */
1334 INLINE char *
1335 bastring_value (sc_or_null sc, _kt_tag t_enum, pko p)
1336 {
1337 WITH_PSYC_UNBOXED(kt_string,p, t_enum, sc);
1338 return pdata->_svalue;
1339 }
1340
1341 INLINE int
1342 bastring_len (sc_or_null sc, _kt_tag t_enum, pko p)
1343 {
1344 WITH_PSYC_UNBOXED(kt_string,p, t_enum, sc);
1345 return pdata->_length;
1346 }
1347
1348 /*_ . Create */
1349
1350 static char *
1351 store_string (int len_str, const char *str, char fill)
1352 {
1353 char *q;
1354
1355 q = (char *) GC_MALLOC_ATOMIC (len_str + 1);
1356 if (str != 0)
1357 {
1358 snprintf (q, len_str + 1, "%s", str);
1359 }
1360 else
1361 {
1362 memset (q, fill, len_str);
1363 q[len_str] = 0;
1364 }
1365 return (q);
1366 }
1367
1368 INLINE pko
1369 mk_bastring (_kt_tag t_enum, const char *str, int len, char fill)
1370 {
1371 ALLOC_BOX_PRESUME (kt_string, t_enum);
1372 pbox->data._svalue = store_string(len, str, fill);
1373 pbox->data._length = len;
1374 return PTR2PKO(pbox);
1375 }
1376
1377 /*_ . Type assert */
1378 void assert_T_is_bastring(_kt_tag t_enum)
1379 {
1380 t_enum &= T_MASKTYPE;
1381 assert(
1382 t_enum == T_STRING ||
1383 t_enum == T_SYMBOL);
1384 }
1385
1386 /*_ . Individual object types */
1387 /*_ , Booleans */
1388
1389 BOX_OF_VOID (K_T);
1390 BOX_OF_VOID (K_F);
1391
1392 DEF_SIMPLE_PRED(is_bool,T_NO_K,ground, "boolean?/o1")
1393 {
1394 WITH_1_ARGS(p);
1395 return (p == K_T) || (p == K_F);
1396 }
1397 /*_ . Operations */
1398 SIG_CHKARRAY(not) = { REF_OPER(is_bool), };
1399 DEF_SIMPLE_APPLICATIVE(p00a1,not,T_NO_K,ground, "not?")
1400 {
1401 WITH_1_ARGS(p);
1402 if(p == K_T) { return K_F; }
1403 if(p == K_F) { return K_T; }
1404 errx(6, "not: Argument must be boolean");
1405 }
1406
1407 /*_ , Numbers */
1408 /*_ . Number constants */
1409 #if 0
1410 /* We would use these for "folding" operations like cumulative addition. */
1411 static num num_zero = { 1, {0}, };
1412 static num num_one = { 1, {1}, };
1413 #endif
1414 /*_ . Macros */
1415 #define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
1416 #define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
1417
1418 /*_ . Making them */
1419
1420 INTERFACE pko
1421 mk_integer (long num)
1422 {
1423 ALLOC_BOX_PRESUME (struct num, T_NUMBER);
1424 pbox->data.value.ivalue = num;
1425 pbox->data.is_fixnum = 1;
1426 return PTR2PKO(pbox);
1427 }
1428
1429 INTERFACE pko
1430 mk_real (double n)
1431 {
1432 ALLOC_BOX_PRESUME (num, T_NUMBER);
1433 pbox->data.value.rvalue = n;
1434 pbox->data.is_fixnum = 0;
1435 return PTR2PKO(pbox);
1436 }
1437
1438 static pko
1439 mk_number (num n)
1440 {
1441 if (n.is_fixnum)
1442 {
1443 return mk_integer (n.value.ivalue);
1444 }
1445 else
1446 {
1447 return mk_real (n.value.rvalue);
1448 }
1449 }
1450
1451 /*_ . Checking them */
1452 static int is_zero_double (double x);
1453
1454 static INLINE int
1455 num_is_integer (pko p)
1456 {
1457 WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1458 return (pdata->is_fixnum);
1459 }
1460
1461 DEF_T_PRED (is_number,T_NUMBER,ground,"number?/o1");
1462
1463 DEF_SIMPLE_PRED (is_posint,T_NO_K,ground,"posint?/o1")
1464 {
1465 WITH_1_ARGS(p);
1466 return is_integer (p) && ivalue (p) >= 0;
1467 }
1468
1469 /* $$IMPROVE ME later Integer and real should be separate T_ types. */
1470 DEF_SIMPLE_PRED (is_integer,T_NO_K,ground, "integer?/o1")
1471 {
1472 WITH_1_ARGS(p);
1473 if(!is_number (p)) { return 0; }
1474 WITH_UNBOXED_UNSAFE(pdata,num,p);
1475 return (pdata->is_fixnum);
1476 }
1477
1478 DEF_SIMPLE_PRED (is_real,T_NO_K,ground, "real?/o1")
1479 {
1480 WITH_1_ARGS(p);
1481 if(!is_number (p)) { return 0; }
1482 WITH_UNBOXED_UNSAFE(pdata,num,p);
1483 return (!pdata->is_fixnum);
1484 }
1485 DEF_SIMPLE_PRED (is_zero,T_NO_K,ground, "zero?/o1")
1486 {
1487 WITH_1_ARGS(p);
1488 /* Behavior on non-numbers wasn't specified so I'm assuming the
1489 predicate just fails. */
1490 if(!is_number (p)) { return 0; }
1491 WITH_UNBOXED_UNSAFE(pdata,num,p);
1492 if(pdata->is_fixnum)
1493 {
1494 return (ivalue (p) == 0);
1495 }
1496 else
1497 {
1498 return is_zero_double(rvalue(p));
1499 }
1500 }
1501 /* $$WRITE ME positive? negative? odd? even? */
1502 /*_ . Getting their values */
1503 INLINE num
1504 nvalue (pko p)
1505 {
1506 WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1507 return ((*pdata));
1508 }
1509
1510 INTERFACE long
1511 ivalue (pko p)
1512 {
1513 WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1514 return (num_is_integer (p) ? pdata->value.ivalue : (long) pdata->
1515 value.rvalue);
1516 }
1517
1518 INTERFACE double
1519 rvalue (pko p)
1520 {
1521 WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1522 return (!num_is_integer (p)
1523 ? pdata->value.rvalue : (double) pdata->value.ivalue);
1524 }
1525
1526 INTERFACE void
1527 set_ivalue (pko p, long i)
1528 {
1529 assert_mutable(0,p);
1530 WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1531 assert (num_is_integer (p));
1532 pdata->value.ivalue = i;
1533 return;
1534 }
1535
1536 INTERFACE void
1537 add_to_ivalue (pko p, long i)
1538 {
1539 assert_mutable(0,p);
1540 WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1541 assert (num_is_integer (p));
1542 pdata->value.ivalue += i;
1543 return;
1544 }
1545
1546 /*_ . Operating on numbers */
1547 static num
1548 num_add (num a, num b)
1549 {
1550 num ret;
1551 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1552 if (ret.is_fixnum)
1553 {
1554 ret.value.ivalue = a.value.ivalue + b.value.ivalue;
1555 }
1556 else
1557 {
1558 ret.value.rvalue = num_rvalue (a) + num_rvalue (b);
1559 }
1560 return ret;
1561 }
1562
1563 static num
1564 num_mul (num a, num b)
1565 {
1566 num ret;
1567 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1568 if (ret.is_fixnum)
1569 {
1570 ret.value.ivalue = a.value.ivalue * b.value.ivalue;
1571 }
1572 else
1573 {
1574 ret.value.rvalue = num_rvalue (a) * num_rvalue (b);
1575 }
1576 return ret;
1577 }
1578
1579 static num
1580 num_div (num a, num b)
1581 {
1582 num ret;
1583 ret.is_fixnum = a.is_fixnum && b.is_fixnum
1584 && a.value.ivalue % b.value.ivalue == 0;
1585 if (ret.is_fixnum)
1586 {
1587 ret.value.ivalue = a.value.ivalue / b.value.ivalue;
1588 }
1589 else
1590 {
1591 ret.value.rvalue = num_rvalue (a) / num_rvalue (b);
1592 }
1593 return ret;
1594 }
1595
1596 static num
1597 num_intdiv (num a, num b)
1598 {
1599 num ret;
1600 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1601 if (ret.is_fixnum)
1602 {
1603 ret.value.ivalue = a.value.ivalue / b.value.ivalue;
1604 }
1605 else
1606 {
1607 ret.value.rvalue = num_rvalue (a) / num_rvalue (b);
1608 }
1609 return ret;
1610 }
1611
1612 static num
1613 num_sub (num a, num b)
1614 {
1615 num ret;
1616 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1617 if (ret.is_fixnum)
1618 {
1619 ret.value.ivalue = a.value.ivalue - b.value.ivalue;
1620 }
1621 else
1622 {
1623 ret.value.rvalue = num_rvalue (a) - num_rvalue (b);
1624 }
1625 return ret;
1626 }
1627
1628 static num
1629 num_rem (num a, num b)
1630 {
1631 num ret;
1632 long e1, e2, res;
1633 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1634 e1 = num_ivalue (a);
1635 e2 = num_ivalue (b);
1636 res = e1 % e2;
1637 /* modulo should have same sign as second operand */
1638 if (res > 0)
1639 {
1640 if (e1 < 0)
1641 {
1642 res -= labs (e2);
1643 }
1644 }
1645 else if (res < 0)
1646 {
1647 if (e1 > 0)
1648 {
1649 res += labs (e2);
1650 }
1651 }
1652 ret.value.ivalue = res;
1653 return ret;
1654 }
1655
1656 static num
1657 num_mod (num a, num b)
1658 {
1659 num ret;
1660 long e1, e2, res;
1661 ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1662 e1 = num_ivalue (a);
1663 e2 = num_ivalue (b);
1664 res = e1 % e2;
1665 if (res * e2 < 0)
1666 { /* modulo should have same sign as second operand */
1667 e2 = labs (e2);
1668 if (res > 0)
1669 {
1670 res -= e2;
1671 }
1672 else
1673 {
1674 res += e2;
1675 }
1676 }
1677 ret.value.ivalue = res;
1678 return ret;
1679 }
1680
1681 static int
1682 num_eq (num a, num b)
1683 {
1684 int ret;
1685 int is_fixnum = a.is_fixnum && b.is_fixnum;
1686 if (is_fixnum)
1687 {
1688 ret = a.value.ivalue == b.value.ivalue;
1689 }
1690 else
1691 {
1692 ret = num_rvalue (a) == num_rvalue (b);
1693 }
1694 return ret;
1695 }
1696
1697
1698 static int
1699 num_gt (num a, num b)
1700 {
1701 int ret;
1702 int is_fixnum = a.is_fixnum && b.is_fixnum;
1703 if (is_fixnum)
1704 {
1705 ret = a.value.ivalue > b.value.ivalue;
1706 }
1707 else
1708 {
1709 ret = num_rvalue (a) > num_rvalue (b);
1710 }
1711 return ret;
1712 }
1713
1714 static int
1715 num_ge (num a, num b)
1716 {
1717 return !num_lt (a, b);
1718 }
1719
1720 static int
1721 num_lt (num a, num b)
1722 {
1723 int ret;
1724 int is_fixnum = a.is_fixnum && b.is_fixnum;
1725 if (is_fixnum)
1726 {
1727 ret = a.value.ivalue < b.value.ivalue;
1728 }
1729 else
1730 {
1731 ret = num_rvalue (a) < num_rvalue (b);
1732 }
1733 return ret;
1734 }
1735
1736 static int
1737 num_le (num a, num b)
1738 {
1739 return !num_gt (a, b);
1740 }
1741
1742 #if USE_MATH
1743 /* Round to nearest. Round to even if midway */
1744 static double
1745 round_per_R5RS (double x)
1746 {
1747 double fl = floor (x);
1748 double ce = ceil (x);
1749 double dfl = x - fl;
1750 double dce = ce - x;
1751 if (dfl > dce)
1752 {
1753 return ce;
1754 }
1755 else if (dfl < dce)
1756 {
1757 return fl;
1758 }
1759 else
1760 {
1761 if (fmod (fl, 2.0) == 0.0)
1762 { /* I imagine this holds */
1763 return fl;
1764 }
1765 else
1766 {
1767 return ce;
1768 }
1769 }
1770 }
1771 #endif
1772
1773 static int
1774 is_zero_double (double x)
1775 {
1776 return x < DBL_MIN && x > -DBL_MIN;
1777 }
1778
1779 static long
1780 binary_decode (const char *s)
1781 {
1782 long x = 0;
1783
1784 while (*s != 0 && (*s == '1' || *s == '0'))
1785 {
1786 x <<= 1;
1787 x += *s - '0';
1788 s++;
1789 }
1790
1791 return x;
1792 }
1793 /*_ , Macros */
1794 /* "Psychically" defines a and b. */
1795 #define WITH_PSYC_AB_ARGS(A_TYPE,B_TYPE) \
1796 WITH_UNBOXED_UNSAFE(a,A_TYPE,arg1); \
1797 WITH_UNBOXED_UNSAFE(b,B_TYPE,arg2)
1798
1799
1800 /*_ , Interface */
1801 /*_ . Binary operations */
1802 SIG_CHKARRAY(num_binop) = { REF_OPER(is_number), REF_OPER(is_number), };
1803 DEF_SIMPLE_DESTR(num_binop);
1804
1805 DEF_APPLICATIVE_W_DESTR(ps0a2,k_add,REF_DESTR(num_binop),0,ground, "add")
1806 {
1807 WITH_PSYC_AB_ARGS(num,num);
1808 ALLOC_BOX_PRESUME(num,T_NUMBER);
1809 *pdata = num_add (*a, *b);
1810 return PTR2PKO(pbox);
1811 }
1812
1813 DEF_APPLICATIVE_W_DESTR(ps0a2,k_sub,REF_DESTR(num_binop),0,ground, "sub")
1814 {
1815 WITH_PSYC_AB_ARGS(num,num);
1816 ALLOC_BOX_PRESUME(num,T_NUMBER);
1817 *pdata = num_sub (*a, *b);
1818 return PTR2PKO(pbox);
1819 }
1820
1821 DEF_APPLICATIVE_W_DESTR(ps0a2,k_mul,REF_DESTR(num_binop),0,ground, "mul")
1822 {
1823 WITH_PSYC_AB_ARGS(num,num);
1824 ALLOC_BOX_PRESUME(num,T_NUMBER);
1825 *pdata = num_mul (*a, *b);
1826 return PTR2PKO(pbox);
1827 }
1828
1829 DEF_APPLICATIVE_W_DESTR(ps0a2,k_div,REF_DESTR(num_binop),0,ground, "div")
1830 {
1831 WITH_PSYC_AB_ARGS(num,num);
1832 ALLOC_BOX_PRESUME(num,T_NUMBER);
1833 *pdata = num_div (*a, *b);
1834 return PTR2PKO(pbox);
1835 }
1836
1837 DEF_APPLICATIVE_W_DESTR(ps0a2,k_mod,REF_DESTR(num_binop),0,ground, "mod")
1838 {
1839 WITH_PSYC_AB_ARGS(num,num);
1840 ALLOC_BOX_PRESUME(num,T_NUMBER);
1841 *pdata = num_mod (*a, *b);
1842 return PTR2PKO(pbox);
1843 }
1844 /*_ . Binary predicates */
1845 DEF_APPLICATIVE_W_DESTR(bs0a2,k_gt,REF_DESTR(num_binop),0,ground, ">?/2")
1846 {
1847 WITH_PSYC_AB_ARGS(num,num);
1848 ALLOC_BOX_PRESUME(num,T_NUMBER);
1849 return num_gt (*a, *b);
1850 }
1851
1852 DEF_APPLICATIVE_W_DESTR(bs0a2,k_eq,REF_DESTR(num_binop),0,simple, "equal?/2-num-num")
1853 {
1854 WITH_PSYC_AB_ARGS(num,num);
1855 ALLOC_BOX_PRESUME(num,T_NUMBER);
1856 return num_eq (*a, *b);
1857 }
1858
1859
1860 /*_ , Characters */
1861 DEF_T_PRED (is_character,T_CHARACTER,ground, "character?/o1");
1862
1863 INTERFACE long
1864 charvalue (pko p)
1865 {
1866 WITH_PSYC_UNBOXED(long,p,T_CHARACTER,0);
1867 return *pdata;
1868 }
1869
1870 INTERFACE pko
1871 mk_character (int c)
1872 {
1873 ALLOC_BOX_PRESUME (long, T_CHARACTER);
1874 pbox->data = c;
1875 return PTR2PKO(pbox);
1876 }
1877
1878 /*_ . Classifying characters */
1879 #if USE_CHAR_CLASSIFIERS
1880 static INLINE int
1881 Cisalpha (int c)
1882 {
1883 return isascii (c) && isalpha (c);
1884 }
1885
1886 static INLINE int
1887 Cisdigit (int c)
1888 {
1889 return isascii (c) && isdigit (c);
1890 }
1891
1892 static INLINE int
1893 Cisspace (int c)
1894 {
1895 return isascii (c) && isspace (c);
1896 }
1897
1898 static INLINE int
1899 Cisupper (int c)
1900 {
1901 return isascii (c) && isupper (c);
1902 }
1903
1904 static INLINE int
1905 Cislower (int c)
1906 {
1907 return isascii (c) && islower (c);
1908 }
1909 #endif
1910 /*_ . Character names */
1911 #if USE_ASCII_NAMES
1912 static const char *charnames[32] = {
1913 "nul",
1914 "soh",
1915 "stx",
1916 "etx",
1917 "eot",
1918 "enq",
1919 "ack",
1920 "bel",
1921 "bs",
1922 "ht",
1923 "lf",
1924 "vt",
1925 "ff",
1926 "cr",
1927 "so",
1928 "si",
1929 "dle",
1930 "dc1",
1931 "dc2",
1932 "dc3",
1933 "dc4",
1934 "nak",
1935 "syn",
1936 "etb",
1937 "can",
1938 "em",
1939 "sub",
1940 "esc",
1941 "fs",
1942 "gs",
1943 "rs",
1944 "us"
1945 };
1946
1947 static int
1948 is_ascii_name (const char *name, int *pc)
1949 {
1950 int i;
1951 for (i = 0; i < 32; i++)
1952 {
1953 if (stricmp (name, charnames[i]) == 0)
1954 {
1955 *pc = i;
1956 return 1;
1957 }
1958 }
1959 if (stricmp (name, "del") == 0)
1960 {
1961 *pc = 127;
1962 return 1;
1963 }
1964 return 0;
1965 }
1966
1967 #endif
1968
1969 /*_ , Void objects */
1970 /*_ . is_key */
1971 DEF_T_PRED (is_key, T_KEY,no,"");
1972
1973
1974 /*_ . Others */
1975 BOX_OF_VOID (K_NIL);
1976 BOX_OF_VOID (K_EOF);
1977 BOX_OF_VOID (K_INERT);
1978 BOX_OF_VOID (K_IGNORE);
1979 /*_ . "Secret" objects for built-in keyed dynamic bindings */
1980 BOX_OF_VOID (K_PRINT_FLAG);
1981 BOX_OF_VOID (K_TRACING);
1982 BOX_OF_VOID (K_INPORT);
1983 BOX_OF_VOID (K_OUTPORT);
1984 BOX_OF_VOID (K_NEST_DEPTH);
1985 /*_ . Keys for typecheck */
1986 BOX_OF_VOID (K_TYCH_DOT);
1987 BOX_OF_VOID (K_TYCH_REPEAT);
1988 BOX_OF_VOID (K_TYCH_OPTIONAL);
1989 BOX_OF_VOID (K_TYCH_IMP_REPEAT);
1990 BOX_OF_VOID (K_TYCH_NO_TYPE);
1991
1992 /*_ . Making them dynamically */
1993 DEF_CFUNC(p00a0, mk_void, K_NO_TYPE,T_NO_K)
1994 {
1995 ALLOC_BOX(pbox,T_KEY,kt_boxed_void);
1996 return PTR2PKO(pbox);
1997 }
1998 /*_ . Type */
1999 DEF_SIMPLE_PRED(is_null,T_NO_K,ground, "null?/o1")
2000 {
2001 WITH_1_ARGS(p);
2002 return p == K_NIL;
2003 }
2004 DEF_SIMPLE_PRED(is_inert,T_NO_K,ground, "inert?/o1")
2005 {
2006 WITH_1_ARGS(p);
2007 return p == K_INERT;
2008 }
2009 DEF_SIMPLE_PRED(is_ignore,T_NO_K,ground, "ignore?/o1")
2010 {
2011 WITH_1_ARGS(p);
2012 return p == K_IGNORE;
2013 }
2014
2015
2016 /*_ , Typecheck & destructure objects */
2017 /*_ . Structures */
2018 /* _car is vector component, _cdr is list component. */
2019 typedef kt_vec2 kt_destr_result;
2020 /* $$OBSOLETE UNUSED */
2021 typedef struct
2022 {
2023 pko remaining; /* Remaining arglist. 0 if we're to
2024 use the value as entire object */
2025 pko typespec; /* Would prefer to can splice vector */
2026 int index; /* Index into vector, if typespec is a
2027 vector. */
2028 } kt_destr_state;
2029 /*_ . Enumeration */
2030 typedef enum
2031 {
2032 destr_success,
2033 destr_err,
2034 destr_must_force,
2035 } kt_destr_outcome;
2036 /*_ . Checks */
2037 DEF_T_PRED (is_destr_result, T_DESTR_RESULT, no, "");
2038 /*_ . Building them */
2039 /*_ , can_be_trivpred */
2040 /* Return true if the object can be used as a trivial predicate: An
2041 xary operative that does not call Kernel and returns a boolean as
2042 an int. */
2043 DEF_SIMPLE_PRED(can_be_trivpred,T_NO_K,unsafe,"trivpred?/o1")
2044 {
2045 WITH_1_ARGS(p);
2046 if(!no_call_k(p)) { return 0; }
2047 switch(_get_type(p))
2048 {
2049 case T_CFUNC:
2050 {
2051 WITH_UNBOXED_UNSAFE(pdata,kt_cfunc,p);
2052 switch(pdata->type)
2053 {
2054 case klink_ftype_b00a1:
2055 { return 1; }
2056 default:
2057 { return 0; }
2058 }
2059 }
2060 /* NOTREACHED */
2061
2062 case T_DESTRUCTURE:
2063 { return 1; }
2064 /* NOTREACHED */
2065
2066 case T_TYPECHECK:
2067 { return 1; }
2068 /* NOTREACHED */
2069 case T_TYPEP:
2070 { return 1; }
2071 /* NOTREACHED */
2072 default: return 0;
2073 }
2074 }
2075
2076 /*_ , k_to_trivpred */
2077 /* Convert a unary or nary function to xary. If not possible, return
2078 nil. */
2079 /* $$OBSOLESCENT Only used in print lookup, which will change */
2080 pko
2081 k_to_trivpred(pko p)
2082 {
2083 if(is_applicative(p))
2084 { p = unwrap_all(p); }
2085
2086 if(can_be_trivpred(p))
2087 { return p; }
2088 return K_NIL;
2089 }
2090
2091 /*_ , type-keys environment */
2092 RGSTR(type-keys, "cyclic-repeat", REF_KEY(K_TYCH_IMP_REPEAT) )
2093 RGSTR(type-keys, "optional", REF_KEY(K_TYCH_OPTIONAL) )
2094 RGSTR(type-keys, "repeat", REF_KEY(K_TYCH_REPEAT) )
2095 RGSTR(type-keys, "dot", REF_KEY(K_TYCH_DOT) )
2096
2097 /*_ , Typecheck */
2098 DEF_APPLICATIVE_W_DESTR (ps0a1, mk_typecheck, REF_OPER(is_finite_list),T_NO_K,unsafe, "listtype/N-trivpred")
2099 {
2100 return mk_basvector_w_args(sc, arg1, T_TYPECHECK | T_NO_K);
2101 }
2102 /*_ , Destructurer */
2103 /* $$RETHINK ME Maybe add a count field to the struct. */
2104 DEF_APPLICATIVE_W_DESTR (ps0a1, mk_destructurer, REF_OPER(is_finite_list),T_NO_K,unsafe, "destructure-list/N-trivpred")
2105 {
2106 return mk_basvector_w_args(sc, arg1, T_DESTRUCTURE | T_NO_K);
2107 }
2108 /*_ , Destructurer Result state */
2109 pko
2110 mk_destr_result
2111 (int len, pko * array, pko more_vals)
2112 {
2113 pko vec = mk_basvector_from_array(len, array, T_VECTOR);
2114 return v2cons (T_DESTR_RESULT, vec, more_vals);
2115 }
2116 /*_ . Particular typechecks */
2117 /*_ , Any singleton */
2118 pko _K_ARRAY_any_singleton[] = { K_ANY, };
2119 DEF_DESTR(_K_any_singleton,_K_ARRAY_any_singleton);
2120 /*_ , Typespec itself */
2121 #define K_TY_TYPESPEC K_ANY
2122 /*_ , Destructure spec itself */
2123 #define K_TY_DESTRSPEC K_ANY
2124 /*_ , Top type (Always succeeds) */
2125 RGSTR(ground, "true/o1", REF_OPER(is_any))
2126 DEF_CFUNC(b00a1,is_any,K_ANY_SINGLETON,T_NO_K)
2127 { return 1; }
2128 /*_ . Internal signatures */
2129 static int
2130 typecheck_repeat
2131 (klink *sc, pko argobject, pko * ar_typespec, int count, int style);
2132 static pko
2133 where_typemiss_repeat
2134 (klink *sc, pko argobject, pko * ar_typespec, int count, int style);
2135 pko
2136 static where_typemiss_do_spec
2137 (klink * sc, pko argobject, pko * ar_typespec, int left);
2138
2139 /*_ . Operations */
2140 inline int
2141 call_T_typecheck(pko T, pko obj)
2142 {
2143 WITH_PSYC_UNBOXED(typep_t,T,T_TYPEP,0);
2144 return is_type(obj,pdata->T_tag);
2145 }
2146 /*_ , typecheck */
2147 /* This is an optimization under-the-hood for running
2148 possibly-compound predicates. Ultimately it will not be exposed.
2149 Later it may have a Kernel "safe counterpart" that is optimized to
2150 it when possible.
2151
2152 It should not call anything that calls Kernel. All its
2153 "components" should be trivpreds (xary operatives that don't use
2154 eval loop), satisfying can_be_trivpred, generally specified
2155 natively in C. */
2156 /* We don't have a typecheck typecheck predicate yet, so accept
2157 anything for arg2. */
2158 SIG_CHKARRAY(typecheck) = { K_ANY, K_ANY, };
2159 DEF_SIMPLE_APPLICATIVE (bs0a2, typecheck,T_NO_K,unsafe,"type?")
2160 {
2161 WITH_2_ARGS(argobject,typespec);
2162 assert(no_call_k(typespec));
2163 switch(_get_type(typespec))
2164 {
2165 case T_CFUNC:
2166 {
2167 WITH_UNBOXED_UNSAFE(pdata,kt_cfunc,typespec);
2168 switch(pdata->type)
2169 {
2170 case klink_ftype_b00a1:
2171 {
2172 return pdata->func.f_b00a1(argobject);
2173 }
2174 default:
2175 errx(7, "typecheck: Object is not a typespec");
2176 }
2177 }
2178 break; /* NOTREACHED */
2179 case T_TYPEP:
2180 return call_T_typecheck(typespec, argobject);
2181 case T_DESTRUCTURE: /* Fallthru */
2182 case T_TYPECHECK:
2183 {
2184 WITH_UNBOXED_UNSAFE(pdata,kt_vector,typespec);
2185 pko * ar_typespec = pdata->els;
2186 int left = pdata->len;
2187 int saw_optional = 0;
2188 for( ; left; ar_typespec++, left--)
2189 {
2190 pko tych = *ar_typespec;
2191 /**** Check for special keys ****/
2192 if(tych == REF_KEY(K_TYCH_DOT))
2193 {
2194 if(left != 2)
2195 {
2196 KERNEL_ERROR_0 (sc, "typecheck: After dot there must "
2197 "be exactly one typespec");
2198 }
2199 else
2200 { return typecheck(sc, argobject, ar_typespec[1]); }
2201 }
2202 if(tych == REF_KEY(K_TYCH_OPTIONAL))
2203 {
2204 if(saw_optional)
2205 {
2206 KERNEL_ERROR_0 (sc, "typecheck: Can't have two optionals");
2207 }
2208 else
2209 {
2210 saw_optional = 1;
2211 continue;
2212 }
2213 }
2214 if(tych == REF_KEY(K_TYCH_REPEAT))
2215 {
2216 return
2217 typecheck_repeat(sc,argobject,
2218 ar_typespec + 1,
2219 left - 1,
2220 0);
2221 }
2222 if(tych == REF_KEY(K_TYCH_IMP_REPEAT))
2223 {
2224 return
2225 typecheck_repeat(sc,argobject,
2226 ar_typespec + 1,
2227 left - 1,
2228 1);
2229 }
2230
2231 /*** Manage stepping ***/
2232 if(!is_pair(argobject))
2233 {
2234 if(!saw_optional)
2235 { return 0; }
2236 else
2237 { return 1; }
2238 }
2239 else
2240 {
2241 /* Advance */
2242 pko c = pair_car(0,argobject);
2243 argobject = pair_cdr(0,argobject);
2244
2245 /*** Do the check ***/
2246 if (!typecheck(sc, c, tych)) { return 0; }
2247 }
2248 }
2249 if(argobject != K_NIL)
2250 { return 0; }
2251 return 1;
2252 }
2253 break;
2254
2255 default:
2256 errx(7, "typecheck: Object is not a typespec");
2257 }
2258 return 0; /* NOTREACHED */
2259 }
2260 /*_ , typecheck_repeat */
2261 static int
2262 typecheck_repeat
2263 (klink *sc, pko argobject, pko * ar_typespec, int count, int style)
2264 {
2265 int4 metrics;
2266 get_list_metrics_aux(argobject, metrics);
2267 /* Dotted lists don't satisfy repeat */
2268 if(!metrics[lm_num_nils]) { return 0; }
2269 if(metrics[lm_cyc_len])
2270 {
2271 /* STYLE may not allow cycles. */
2272 if(!style)
2273 { return 0; }
2274 /* If there's a cycle and count doesn't fit into it exactly,
2275 call that a mismatch. */
2276 if(count % metrics[lm_cyc_len])
2277 { return 0; }
2278 }
2279 /* Check the car of each pair. */
2280 int step;
2281 int i;
2282 for(step = 0, i = 0;
2283 step < metrics[lm_num_pairs];
2284 ++step, ++i, argobject = pair_cdr(0,argobject))
2285 {
2286 if(i == count) { i = 0; }
2287 assert(is_pair(argobject));
2288 pko tych = ar_typespec[i];
2289 pko c = pair_car(0,argobject);
2290 if (!typecheck(sc, c, tych)) { return 0; }
2291 }
2292 return 1;
2293 }
2294 /*_ , destructure_make_ops */
2295 pko
2296 destructure_make_ops (pko argobject, pko typespec, int saw_optional)
2297 {
2298 return
2299 /* Operations to run, in reverse order. */
2300 LIST6(
2301 REF_OPER (destructure_resume),
2302 /* ^V= (result-so-far argobject spec optional?) */
2303 mk_load (LIST4 (mk_load_ix (1, 0),
2304 mk_load_ix (0, 0),
2305 typespec,
2306 kernel_bool (saw_optional))),
2307 mk_store (K_ANY, 1),
2308 REF_OPER (force),
2309 mk_load (LIST1 (argobject)),
2310 mk_store (K_ANY, 4));
2311 }
2312
2313 /*_ , destructure */
2314 /* Callers: past_end should point into the same array as *outarray.
2315 It will indicate the maximum number number of elements we may
2316 write. The return value is the remainder of the outarray if
2317 successful, otherwise NULL.
2318 */
2319 kt_destr_outcome
2320 destructure
2321 (klink * sc, pko argobject, pko typespec, pko ** outarray,
2322 pko * past_end, pko * extra_result, int saw_optional)
2323 {
2324 if(*outarray == past_end)
2325 {
2326 KERNEL_ERROR_0 (sc, "destructure: past end of output array");
2327 }
2328 assert(no_call_k(typespec));
2329 if(_get_type(typespec) == T_DESTRUCTURE)
2330 {
2331 WITH_UNBOXED_UNSAFE(pdata,kt_vector,typespec);
2332 pko * ar_typespec = pdata->els;
2333 int left = pdata->len;
2334 for( ; left; ar_typespec++, left--)
2335 {
2336 pko tych = *ar_typespec;
2337
2338 /**** Check for special keys ****/
2339 if(tych == REF_KEY(K_TYCH_DOT))
2340 {
2341 if(left != 2)
2342 {
2343 KERNEL_ERROR_0 (sc, "destructure: After dot there must "
2344 "be exactly one typespec");
2345 }
2346 else
2347 { return destructure(sc, argobject,
2348 ar_typespec[1],
2349 outarray,
2350 past_end,
2351 extra_result,
2352 0);
2353 }
2354 }
2355 if(tych == REF_KEY(K_TYCH_OPTIONAL))
2356 {
2357 if(saw_optional)
2358 {
2359 KERNEL_ERROR_0 (sc, "destructure: Can't have two optionals");
2360 }
2361 else
2362 {
2363 saw_optional = 1;
2364 continue;
2365 }
2366 }
2367 /*** Manage stepping ***/
2368 if(!is_pair(argobject))
2369 {
2370 if(saw_optional)
2371 {
2372 *outarray[0] = K_INERT;
2373 ++*outarray;
2374 }
2375 else
2376 if (is_promise (argobject))
2377 {
2378 pko new_typespec =
2379 mk_foresliced_basvector (typespec,
2380 pdata->len - left,
2381 T_DESTRUCTURE);
2382 *extra_result =
2383 destructure_make_ops (argobject,
2384 new_typespec,
2385 saw_optional);
2386 return destr_must_force;
2387 }
2388 else
2389 {
2390 return destr_err;
2391 }
2392 }
2393 else
2394 {
2395 pko c = pair_car(0,argobject);
2396 argobject = pair_cdr(0,argobject);
2397 int outcome =
2398 destructure (sc,
2399 c,
2400 tych,
2401 outarray,
2402 past_end,
2403 extra_result,
2404 0);
2405 if (outcome != destr_success) { return outcome; }
2406 }
2407 }
2408 if(argobject == K_NIL)
2409 { return destr_success; }
2410 else if (is_promise (argobject))
2411 {
2412 pko new_typespec = REF_OPER (is_null);
2413 *extra_result =
2414 destructure_make_ops (argobject,
2415 new_typespec,
2416 saw_optional);
2417 return destr_must_force;
2418 }
2419 else
2420 { return destr_err; }
2421
2422 }
2423 else if(typecheck(sc, argobject, typespec))
2424 {
2425 *outarray[0] = argobject;
2426 ++*outarray;
2427 return destr_success;
2428 }
2429 else if (is_promise (argobject))
2430 {
2431 *extra_result =
2432 destructure_make_ops (argobject,
2433 typespec,
2434 0);
2435 return destr_must_force;
2436 }
2437 else
2438 {
2439 return destr_err;
2440 }
2441 }
2442 /*_ , where_typemiss */
2443 /* This parallels typecheck, but where typecheck returned a boolean,
2444 this returns an object indicating where the type failed to match. */
2445 SIG_CHKARRAY(where_typemiss) = { K_ANY, K_ANY, };
2446 DEF_SIMPLE_APPLICATIVE (ps0a2, where_typemiss,T_NO_K,unsafe, "where-typemiss")
2447 {
2448 /* Return a list indicating how TYPESPEC failed to match
2449 ARGOBJECT */
2450 WITH_2_ARGS(argobject,typespec);
2451 assert(no_call_k(typespec));
2452 switch(_get_type(typespec))
2453 {
2454 case T_CFUNC:
2455 {
2456 WITH_UNBOXED_UNSAFE(pdata,kt_cfunc,typespec);
2457 switch(pdata->type)
2458 {
2459 case klink_ftype_b00a1:
2460 {
2461 if (pdata->func.f_b00a1(argobject))
2462 {
2463 return 0;
2464 }
2465 else
2466 { return LIST1(typespec); }
2467 }
2468 default:
2469 errx(7, "where_typemiss: Object is not a typespec");
2470 return 0;
2471 }
2472 }
2473 break; /* NOTREACHED */
2474 case T_TYPEP:
2475 {
2476 WITH_PSYC_UNBOXED(typep_t,typespec,T_TYPEP,0);
2477 if (call_T_typecheck(typespec, argobject))
2478 { return 0; }
2479 else
2480 { return LIST1(mk_string(type_err_string(pdata->T_tag))); }
2481 }
2482
2483 case T_TYPECHECK:
2484 case T_DESTRUCTURE:
2485 {
2486 WITH_UNBOXED_UNSAFE(pdata,kt_vector,typespec);
2487 return where_typemiss_do_spec(sc, argobject, pdata->els, pdata->len);
2488 }
2489
2490 default:
2491 errx(7,"where_typemiss: Object is not a typespec");
2492 return 0;
2493 }
2494 return 0; /* NOTREACHED */
2495 }
2496 /*_ , where_typemiss_do_spec */
2497 pko
2498 where_typemiss_do_spec
2499 (klink * sc, pko argobject, pko * ar_typespec, int left)
2500 {
2501 int saw_optional = 0;
2502 int el_num = 0;
2503 for( ; left; ar_typespec++, left--)
2504 {
2505 pko tych = *ar_typespec;
2506 /**** Check for special keys ****/
2507 if(tych == REF_KEY(K_TYCH_DOT))
2508 {
2509 if(left != 2)
2510 {
2511 KERNEL_ERROR_0 (sc, "where_typemiss: After dot there must "
2512 "be exactly one typespec");
2513 }
2514 else
2515 {
2516 pko result =
2517 where_typemiss(sc, argobject, ar_typespec[1]);
2518 if(result)
2519 {
2520 return
2521 LISTSTAR3(mk_integer(el_num),
2522 mk_symbol("dot"),
2523 result);
2524 }
2525 else
2526 { return 0; }
2527 }
2528 }
2529 if(tych == REF_KEY(K_TYCH_OPTIONAL))
2530 {
2531 if(saw_optional)
2532 {
2533 KERNEL_ERROR_0 (sc, "where_typemiss: Can't have two optionals");
2534 }
2535 else
2536 {
2537 saw_optional = 1;
2538 continue;
2539 }
2540 }
2541 if(tych == REF_KEY(K_TYCH_REPEAT))
2542 {
2543 pko result =
2544 where_typemiss_repeat(sc,argobject,
2545 ar_typespec + 1,
2546 left - 1,
2547 0);
2548 if(result)
2549 { return LISTSTAR3(mk_integer(el_num),mk_symbol("repeat"), result); }
2550 else
2551 { return 0; }
2552 }
2553 if(tych == REF_KEY(K_TYCH_IMP_REPEAT))
2554 {
2555 pko result =
2556 where_typemiss_repeat(sc,argobject,
2557 ar_typespec + 1,
2558 left - 1,
2559 1);
2560 if(result)
2561 { return LISTSTAR3(mk_integer(el_num),mk_symbol("improper-repeat"),result); }
2562 else
2563 { return 0; }
2564 }
2565
2566 /*** Manage stepping ***/
2567 if(!is_pair(argobject))
2568 {
2569 if(!saw_optional)
2570 {
2571 return LIST2(mk_integer(el_num), mk_symbol("too-few"));
2572 }
2573 else
2574 { return 0; }
2575 }
2576 else
2577 {
2578 /* Advance */
2579 pko c = pair_car(0,argobject);
2580 argobject = pair_cdr(0,argobject);
2581 el_num++;
2582
2583 /*** Do the check ***/
2584 pko result = where_typemiss(sc, c, tych);
2585 if (result)
2586 { return LISTSTAR2(mk_integer(el_num),result); }
2587 }
2588 }
2589 if(argobject != K_NIL)
2590 { return LIST2(mk_integer(el_num), mk_symbol("too-many")); }
2591 return 0;
2592 }
2593
2594 /*_ , where_typemiss_repeat */
2595 static pko
2596 where_typemiss_repeat
2597 (klink *sc, pko argobject, pko * ar_typespec, int count, int style)
2598 {
2599 int4 metrics;
2600 get_list_metrics_aux(argobject, metrics);
2601 /* Dotted lists don't satisfy repeat */
2602 if(!metrics[lm_num_nils]) { return LIST1(mk_symbol("dotted")); }
2603 if(metrics[lm_cyc_len])
2604 {
2605 /* STYLE may not allow cycles. */
2606 if(!style)
2607 { return LIST1(mk_symbol("circular")); }
2608 /* If there's a cycle and count doesn't fit into it exactly,
2609 call that a mismatch. */
2610 if(count % metrics[lm_cyc_len])
2611 { return LIST1(mk_symbol("misaligned-end")); }
2612 }
2613 /* Check the car of each pair. */
2614 int step;
2615 int i;
2616 for(step = 0, i = 0;
2617 step < metrics[lm_num_pairs];
2618 ++step, ++i, argobject = pair_cdr(0,argobject))
2619 {
2620 if(i == count) { i = 0; }
2621 assert(is_pair(argobject));
2622 pko tych = ar_typespec[i];
2623 pko c = pair_car(0,argobject);
2624 pko result = where_typemiss(sc, c, tych);
2625 if (result)
2626 { return LISTSTAR2(mk_integer(step),result); }
2627 }
2628 return 0;
2629 }
2630 /*_ , destructure_to_array */
2631 inline kt_destr_outcome
2632 destructure_to_array
2633 (klink * sc, pko obj, pko type, pko * array, size_t length, pko * perr)
2634 {
2635 if (type == K_NO_TYPE)
2636 { return destr_success; }
2637 /* $$IMPROVE ME Get expected max_args and limit to that length */
2638 kt_destr_outcome outcome =
2639 destructure (sc, obj, type, &array, array + length, perr, 0);
2640 switch (outcome)
2641 {
2642 case destr_success:
2643 return destr_success;
2644 /* NOTREACHED */
2645 case destr_err:
2646 {
2647 pko err = where_typemiss (sc, obj, type);
2648 *perr = err ? err : mk_string("Couldn't find the typemiss");
2649 return destr_err;
2650 }
2651 /* NOTREACHED */
2652
2653 case destr_must_force:
2654 /* $$IMPROVE ME Arrange for another force+resume. */
2655 KERNEL_ERROR_0 (sc, "Not supported yet");
2656 /* Indicate length actually read. Possibly by prepending a load
2657 of that. */
2658 /* NOTREACHED */
2659
2660 default:
2661 errx (7, "Unrecognized enumeration");
2662 }
2663 }
2664
2665 /*_ , destructure_resume */
2666 SIG_CHKARRAY (destructure_resume) =
2667 {
2668 REF_OPER (is_destr_result),
2669 K_ANY,
2670 K_TY_DESTRSPEC,
2671 REF_OPER (is_bool),
2672 };
2673 DEF_SIMPLE_CFUNC (ps0a4, destructure_resume, 0)
2674 {
2675 WITH_4_ARGS (destr_result, argobject, typespec, opt_p);
2676 const int max_args = 5;
2677 pko arg_array [max_args];
2678 pko * outarray = arg_array;
2679 pko err;
2680 /* $$IMPROVE ME We need a way of saying whether it's in optional */
2681 kt_destr_outcome outcome =
2682 destructure (sc,
2683 argobject,
2684 typespec,
2685 &outarray,
2686 arg_array + max_args,
2687 &err,
2688 (opt_p == K_T));
2689 switch (outcome)
2690 {
2691 case destr_success:
2692 /* $$IMPROVE ME Push more args */
2693 return destr_result;
2694 /* NOTREACHED */
2695 case destr_err:
2696 /* $$IMPROVE ME Get and report typemiss err */
2697 KERNEL_ERROR_0 (sc, "do_destructure: argobject is the wrong type");
2698 /* NOTREACHED */
2699
2700 case destr_must_force:
2701 /* $$IMPROVE ME Arrange for another force+resume. */
2702 KERNEL_ERROR_0 (sc, "Not supported yet");
2703 /* NOTREACHED */
2704
2705 default:
2706 errx (7, "Unrecognized enumeration");
2707 }
2708 }
2709
2710 /*_ , do-destructure */
2711 /* We don't have a typecheck typecheck predicate yet, so accept
2712 anything for arg2. Really it can be what typecheck accepts or
2713 T_DESTRUCTURE, checked recursively. */
2714 SIG_CHKARRAY (do_destructure) = { K_ANY, K_ANY, };
2715 DEF_SIMPLE_APPLICATIVE (ps0a2, do_destructure,T_NO_K,unsafe,"do-destructure")
2716 {
2717 WITH_2_ARGS (argobject,typespec);
2718 /* A feint to get the length! We'll replace this later. */
2719 const int max_args = 5;
2720 pko arg_array [max_args];
2721 pko * outarray = arg_array;
2722 pko err;
2723 kt_destr_outcome outcome =
2724 destructure (sc,
2725 argobject,
2726 typespec,
2727 &outarray,
2728 arg_array + max_args,
2729 &err,
2730 0);
2731 if (outcome != destr_success)
2732 {
2733 /* $$IMPROVE ME Get and report typemiss err */
2734 KERNEL_ERROR_0 (sc, "do_destructure: argobject is the wrong type");
2735 }
2736 int len = outarray - arg_array;
2737 pko vec = mk_vector (len, K_NIL);
2738 WITH_UNBOXED_UNSAFE (pdata,kt_vector,vec);
2739 outarray = pdata->els;
2740 outcome =
2741 destructure (sc, argobject, typespec, &outarray, outarray + len, &err, 0);
2742 assert (outcome == destr_success);
2743 return vec;
2744 }
2745
2746 /*_ , C functions as objects */
2747 /*_ . Structs */
2748 /*_ , store */
2749 typedef struct kt_opstore
2750 {
2751 pko destr; /* Often a T_DESTRUCTURE */
2752 int frame_depth;
2753 } kt_opstore;
2754
2755 /*_ . cfunc */
2756 DEF_T_PRED (is_cfunc, T_CFUNC,no,"");
2757
2758 #if 0
2759 /* For external use, if some code ever wants to make these objects
2760 dynamically. */
2761 /* $$MAKE ME SAFE Set type-check fields */
2762 pko
2763 mk_cfunc (const kt_cfunc * f)
2764 {
2765 typedef kt_boxed_cfunc TT;
2766 errx(4, "Don't use mk_cfunc yet")
2767 TT *pbox = GC_MALLOC (sizeof (TT));
2768 pbox->type = T_CFUNC;
2769 pbox->data = *f;
2770 return PTR2PKO(pbox);
2771 }
2772 #endif
2773
2774 INLINE const kt_cfunc *
2775 get_cfunc_func (pko p)
2776 {
2777 WITH_PSYC_UNBOXED(kt_cfunc,p,T_CFUNC,0)
2778 return pdata;
2779 }
2780 /*_ . cfunc_resume */
2781 /*_ , Create */
2782 /*_ . mk_cfunc_resume */
2783 pko
2784 mk_cfunc_resume (pko cfunc)
2785 {
2786 ALLOC_BOX_PRESUME (kt_cfunc, T_CFUNC_RESUME);
2787 pbox->data = *get_cfunc_func (cfunc);
2788 return PTR2PKO(pbox);
2789 }
2790
2791 /*_ . Curried functions */
2792 /*_ , About objects */
2793 static INLINE int
2794 is_curried (pko p)
2795 { return is_type (p, T_CURRIED); }
2796
2797 INLINE pko
2798 mk_curried (decurrier_f decurrier, pko args, pko next)
2799 {
2800 ALLOC_BOX(pbox,T_CURRIED,kt_boxed_curried);
2801 pbox->data.decurrier = decurrier;
2802 pbox->data.args = args;
2803 pbox->data.next = next;
2804 pbox->data.argcheck = 0;
2805 return PTR2PKO(pbox);
2806 }
2807 /*_ , Operations */
2808 /*_ . call_curried */
2809 pko
2810 call_curried(klink * sc, pko curried, pko value)
2811 {
2812 WITH_PSYC_UNBOXED(kt_curried,curried,T_CURRIED,sc);
2813
2814 /* First schedule the next one if there is any */
2815 if(pdata->next)
2816 {
2817 klink_push_cont(sc, pdata->next);
2818 }
2819
2820 /* Then call the decurrier with the data field and the value,
2821 returning its result. */
2822 return pdata->decurrier (sc, pdata->args, value);
2823 }
2824
2825 /*_ . Chains */
2826 /*_ , Struct */
2827 typedef kt_vector kt_chain;
2828
2829 /*_ , Creating */
2830 /*_ . Statically */
2831 #define SIG_CHAIN(C_NAME) pko CHAIN_NAME(C_NAME)[]
2832 #define DEF_CHAIN(NAME, ARRAY_NAME) \
2833 DEF_VEC(T_CHAIN | T_IMMUTABLE, NAME, ARRAY_NAME)
2834
2835 #define DEF_SIMPLE_CHAIN(C_NAME) \
2836 RGSTR(all-builtins,"C-" #C_NAME, REF_OPER (C_NAME)) \
2837 DEF_CHAIN(OPER(C_NAME), CHAIN_NAME(C_NAME))
2838
2839
2840 /*_ , Operations */
2841 void
2842 schedule_chain(klink * sc, const kt_vector * chain)
2843 {
2844 _kt_spagstack dump = sc->dump;
2845 int i;
2846 for(i = chain->len - 1; i >= 0; i--)
2847 {
2848 pko comb = chain->els[i];
2849 /* If frame_depth is unassigned, assign it. */
2850 if(_get_type(comb) == T_STORE)
2851 {
2852 WITH_UNBOXED_UNSAFE( pdata, kt_opstore, comb );
2853 if(pdata->frame_depth < 0)
2854 { pdata->frame_depth = chain->len - 1 - i; }
2855 }
2856 /* Push it as a combiner */
2857 dump = klink_push_cont_aux(dump, comb, sc->envir);
2858 }
2859 sc->dump = dump;
2860 }
2861
2862 /*_ . eval_chain */
2863 pko
2864 eval_chain( klink * sc, pko functor, pko value )
2865 {
2866 WITH_PSYC_UNBOXED( kt_vector, functor, T_CHAIN, 0 );
2867 schedule_chain( sc, pdata);
2868 return value;
2869 }
2870 /*_ . schedule_rv_list */
2871 void
2872 schedule_rv_list(klink * sc, pko list)
2873 {
2874 WITH_REPORTER (sc);
2875 _kt_spagstack dump = sc->dump;
2876 for(; list != K_NIL; list = cdr (list))
2877 {
2878 pko comb = car (list);
2879 /* $$PUNT If frame_depth is unassigned, assign it. */
2880
2881 /* Push it as a combiner */
2882 dump = klink_push_cont_aux(dump, comb, sc->envir);
2883 }
2884 sc->dump = dump;
2885 }
2886 /*_ . No-trace */
2887 /*_ , Create */
2888 inline static pko
2889 mk_notrace( pko combiner )
2890 {
2891 ALLOC_BOX_PRESUME( pko, T_NOTRACE );
2892 *pdata = combiner;
2893 return PTR2PKO(pbox);
2894 }
2895
2896 /*_ , Parts */
2897 inline static pko
2898 notrace_comb( pko p )
2899 {
2900 WITH_PSYC_UNBOXED( pko, p, T_NOTRACE, 0 );
2901 return *pdata;
2902 }
2903 /*_ . Store */
2904 /*_ , Create */
2905 /*_ . statically */
2906 #define STORE_DEF(DATA) \
2907 { T_STORE | T_IMMUTABLE, { DATA, -1, }, }
2908
2909 #define ANON_STORE(DATA) \
2910 ANON_REF (kt_opstore, STORE_DEF(DATA))
2911
2912 /*_ . dynamically */
2913 pko
2914 mk_store (pko data, int depth)
2915 {
2916 ALLOC_BOX_PRESUME(kt_opstore, T_STORE | T_IMMUTABLE);
2917 pdata->destr = data;
2918 pdata->frame_depth = depth;
2919 return PTR2PKO(pbox);
2920 }
2921
2922 /*_ . Load */
2923 /*_ , Struct */
2924 typedef pko kt_opload;
2925
2926 /*_ , Create */
2927 /*_ . statically */
2928 #define LOAD_DEF( DATA ) \
2929 { T_LOAD | T_IMMUTABLE, DATA, }
2930
2931 #define ANON_LOAD( DATA ) \
2932 ANON_REF( pko, LOAD_DEF( DATA ))
2933
2934 #define ANON_LOAD_IX( X, Y ) \
2935 ANON_PAIR(ANON_REF(num, INT_DEF( X )), \
2936 ANON_REF(num, INT_DEF( Y )))
2937 /*_ . dynamically */
2938 /*_ , mk_load_ix */
2939 pko
2940 mk_load_ix (int x, int y)
2941 {
2942 return cons (mk_integer (x), mk_integer (y));
2943 }
2944 /*_ , mk_load */
2945 pko
2946 mk_load (pko data)
2947 {
2948 ALLOC_BOX_PRESUME(kt_opload, T_LOAD | T_IMMUTABLE);
2949 *pdata = data;
2950 return PTR2PKO(pbox);
2951 }
2952
2953 /*_ , pairs proper */
2954 /*_ . Type */
2955 DEF_T_PRED (is_pair, T_PAIR,ground, "pair?/o1");
2956
2957 /*_ . Create */
2958 SIG_CHKARRAY(Xcons) = { K_ANY, K_ANY, };
2959 DEF_SIMPLE_DESTR(Xcons);
2960 DEF_APPLICATIVE_W_DESTR(p00a2,mk_pair, REF_DESTR(Xcons),T_NO_K,ground, "cons")
2961 {
2962 WITH_2_ARGS(a,b);
2963 return cons (a, b);
2964 }
2965
2966 DEF_APPLICATIVE_W_DESTR(p00a2,mk_mutable_pair, REF_DESTR(Xcons),T_NO_K,ground, "mcons")
2967 {
2968 WITH_2_ARGS(a,b);
2969 return mcons (a, b);
2970 }
2971
2972 /*_ . Parts and operations */
2973
2974 SIG_CHKARRAY(pair_cxr) = { REF_OPER(is_pair), };
2975 DEF_SIMPLE_DESTR(pair_cxr);
2976 DEF_APPLICATIVE_W_DESTR(ps0a1,pair_car, REF_DESTR(pair_cxr),T_NO_K,ground, "car")
2977 {
2978 WITH_1_ARGS(p);
2979 return v2car(sc,T_PAIR,p);
2980 }
2981
2982 DEF_APPLICATIVE_W_DESTR(ps0a1,pair_cdr, REF_DESTR(pair_cxr),T_NO_K,ground, "cdr")
2983 {
2984 WITH_1_ARGS(p);
2985 return v2cdr(sc,T_PAIR,p);
2986 }
2987
2988 SIG_CHKARRAY(pair_set_cxr) = { REF_OPER(is_pair), K_ANY, };
2989 DEF_SIMPLE_DESTR(pair_set_cxr);
2990 DEF_APPLICATIVE_W_DESTR(ps0a2,set_car, REF_DESTR(pair_set_cxr),T_NO_K,ground, "set-car!")
2991 {
2992 WITH_2_ARGS(p,q);
2993 v2set_car(sc,T_PAIR,p,q);
2994 return K_INERT;
2995 }
2996
2997 DEF_APPLICATIVE_W_DESTR(ps0a2,set_cdr, REF_DESTR(pair_set_cxr),T_NO_K,ground, "set-cdr!")
2998 {
2999 WITH_2_ARGS(p,q);
3000 v2set_cdr(sc,T_PAIR,p,q);
3001 return K_INERT;
3002 }
3003
3004
3005 /*_ , Strings */
3006 /*_ . Type */
3007 DEF_T_PRED (is_string, T_STRING,ground,"string?/o1");
3008 /*_ . Create */
3009
3010 INTERFACE INLINE pko
3011 mk_string (const char *str)
3012 {
3013 return mk_bastring (T_STRING, str, strlen (str), 0);
3014 }
3015
3016 INTERFACE INLINE pko
3017 mk_counted_string (const char *str, int len)
3018 {
3019 return mk_bastring (T_STRING, str, len, 0);
3020 }
3021
3022 INTERFACE INLINE pko
3023 mk_empty_string (int len, char fill)
3024 {
3025 return mk_bastring (T_STRING, 0, len, fill);
3026 }
3027 /*_ . Create static */
3028 /* $$WRITE ME As for k_print_terminate_list macros */
3029
3030 /*_ . Accessors */
3031 INTERFACE INLINE char *
3032 string_value (pko p)
3033 {
3034 return bastring_value(0,T_STRING,p);
3035 }
3036
3037 INTERFACE INLINE int
3038 string_len (pko p)
3039 {
3040 return bastring_len(0,T_STRING,p);
3041 }
3042
3043 /*_ , Symbols */
3044 /*_ . Type */
3045 DEF_T_PRED(is_symbol, T_SYMBOL,ground,"symbol?/o1");
3046 /*_ . Create */
3047 static pko
3048 mk_symbol_obj (const char *name)
3049 {
3050 return mk_bastring (T_SYMBOL | T_IMMUTABLE, name, strlen (name), 0);
3051 }
3052
3053 /* We want symbol objects to be unique per name, so check an oblist of
3054 unique symbols. */
3055 INTERFACE pko
3056 mk_symbol (const char *name)
3057 {
3058 /* first check oblist */
3059 pko x = oblist_find_by_name (name);
3060 if (x != K_NIL)
3061 {
3062 return x;
3063 }
3064 else
3065 {
3066 x = oblist_add_by_name (name);
3067 return x;
3068 }
3069 }
3070 /*_ . oblist implementation */
3071 /*_ , Global object */
3072 static pko oblist = 0;
3073 /*_ , Oblist as hash table */
3074 #ifndef USE_OBJECT_LIST
3075
3076 static int hash_fn (const char *key, int table_size);
3077
3078 static pko
3079 oblist_initial_value ()
3080 {
3081 return mk_vector (461, K_NIL);
3082 }
3083
3084 /* returns the new symbol */
3085 static pko
3086 oblist_add_by_name (const char *name)
3087 {
3088 pko x = mk_symbol_obj (name);
3089 int location = hash_fn (name, vector_len (oblist));
3090 set_vector_elem (oblist, location,
3091 cons (x, vector_elem (oblist, location)));
3092 return x;
3093 }
3094
3095 static INLINE pko
3096 oblist_find_by_name (const char *name)
3097 {
3098 int location;
3099 pko x;
3100 char *s;
3101 WITH_REPORTER(0);
3102
3103 location = hash_fn (name, vector_len (oblist));
3104 for (x = vector_elem (oblist, location); x != K_NIL; x = cdr (x))
3105 {
3106 s = symname (0,car (x));
3107 /* case-insensitive, per R5RS section 2. */
3108 if (stricmp (name, s) == 0)
3109 {
3110 return car (x);
3111 }
3112 }
3113 return K_NIL;
3114 }
3115
3116 static pko
3117 oblist_all_symbols (void)
3118 {
3119 int i;
3120 pko x;
3121 pko ob_list = K_NIL;
3122
3123 for (i = 0; i < vector_len (oblist); i++)
3124 {
3125 for (x = vector_elem (oblist, i); x != K_NIL; x = cdr (x))
3126 {
3127 ob_list = mcons (x, ob_list);
3128 }
3129 }
3130 return ob_list;
3131 }
3132
3133 /*_ , Oblist as list */
3134 #else
3135
3136 static pko
3137 oblist_initial_value ()
3138 {
3139 return K_NIL;
3140 }
3141
3142 static INLINE pko
3143 oblist_find_by_name (const char *name)
3144 {
3145 pko x;
3146 char *s;
3147 WITH_REPORTER(0);
3148 for (x = oblist; x != K_NIL; x = cdr (x))
3149 {
3150 s = symname (0,car (x));
3151 /* case-insensitive, per R5RS section 2. */
3152 if (stricmp (name, s) == 0)
3153 {
3154 return car (x);
3155 }
3156 }
3157 return K_NIL;
3158 }
3159
3160 /* returns the new symbol */
3161 static pko
3162 oblist_add_by_name (const char *name)
3163 {
3164 pko x = mk_symbol_obj (name);
3165 oblist = cons (x, oblist);
3166 return x;
3167 }
3168
3169 static pko
3170 oblist_all_symbols (void)
3171 {
3172 return oblist;
3173 }
3174
3175 #endif
3176
3177
3178 /*_ . Parts and operations */
3179 SIG_CHKARRAY(string_to_symbol) = { REF_OPER(is_string), };
3180 DEF_SIMPLE_APPLICATIVE(ps0a1,string_to_symbol,T_NO_K,ground, "string->symbol")
3181 {
3182 return mk_symbol(string_value(arg1));
3183 }
3184
3185 INTERFACE INLINE char *
3186 symname (sc_or_null sc, pko p)
3187 {
3188 return bastring_value (sc,T_SYMBOL, p);
3189 }
3190
3191
3192 /*_ , Vectors */
3193
3194 /*_ . Type */
3195 DEF_T_PRED (is_vector, T_VECTOR,unsafe,"vector?/o1");
3196
3197 /*_ . Create */
3198 /*_ , mk_vector (T_ level) */
3199 INTERFACE static pko
3200 mk_vector (int len, pko fill)
3201 { return mk_filled_basvector(len, fill, T_VECTOR); }
3202
3203 /*_ , k_mk_vector (K level) */
3204 /* $$RETHINK ME This may not be wanted. */
3205 SIG_CHKARRAY(k_mk_vector) = { REF_OPER(is_integer), REF_KEY(K_TYCH_OPTIONAL), K_ANY, };
3206 DEF_SIMPLE_APPLICATIVE (ps0a2, k_mk_vector,T_NO_K,unsafe,"make-vector")
3207 {
3208 WITH_2_ARGS(k_len, fill);
3209
3210 int len = ivalue (k_len);
3211 if (fill == K_INERT)
3212 { fill = K_NIL; }
3213 return mk_vector (len, fill);
3214 }
3215
3216 /*_ , vector */
3217 /* K_ANY instead of REF_OPER(is_finite_list) because
3218 mk_basvector_w_args checks list-ness internally */
3219 DEF_APPLICATIVE_W_DESTR(ps0a1, vector, K_ANY,T_NO_K,unsafe,"vector")
3220 {
3221 WITH_1_ARGS(p);
3222 return mk_basvector_w_args(sc,p,T_VECTOR);
3223 }
3224
3225 /*_ . Operations (T_ level) */
3226 /*_ , fill_vector */
3227
3228 INTERFACE static void
3229 fill_vector (pko vec, pko obj)
3230 {
3231 assert(_get_type(vec) == T_VECTOR);
3232 unsafe_basvector_fill(vec,obj);
3233 }
3234
3235 /*_ . Parts of vectors (T_ level) */
3236
3237 INTERFACE static int
3238 vector_len (pko vec)
3239 {
3240 assert(_get_type(vec) == T_VECTOR);
3241 return basvector_len(vec);
3242 }
3243
3244 INTERFACE static pko
3245 vector_elem (pko vec, int ielem)
3246 {
3247 assert(_get_type(vec) == T_VECTOR);
3248 return basvector_elem(vec, ielem);
3249 }
3250
3251 INTERFACE static void
3252 set_vector_elem (pko vec, int ielem, pko a)
3253 {
3254 assert(_get_type(vec) == T_VECTOR);
3255 basvector_set_elem(vec, ielem, a);
3256 return;
3257 }
3258
3259 /*_ , Promises */
3260 /* T_PROMISE is essentially a handle, pointing to a pair of either
3261 (expression env) or (value #f). We use #f, not nil, because nil is
3262 a possible environment. */
3263
3264 /*_ . Create */
3265 /*_ , $lazy */
3266 RGSTR(ground,"$lazy", REF_OPER(mk_promise_lazy))
3267 DEF_CFUNC(ps0a1, mk_promise_lazy, K_ANY_SINGLETON, T_NO_K)
3268 {
3269 WITH_1_ARGS(p);
3270 pko guts = mcons(p, mcons(sc->envir, mk_continuation(sc->dump)));
3271 return v2cons (T_PROMISE, guts, K_NIL);
3272 }
3273 /*_ , memoize */
3274 /* $$CHECK ME Is K_ANY correct? Or K_ANY_SINGLETON? */
3275 DEF_APPLICATIVE_W_DESTR(p00a1,mk_promise_memo,K_ANY,T_NO_K,ground,"memoize")
3276 {
3277 WITH_1_ARGS(p);
3278 pko guts = mcons(p, K_F);
3279 return v2cons (T_PROMISE, guts, K_NIL);
3280 }
3281 /*_ . Type */
3282
3283 DEF_T_PRED (is_promise,T_PROMISE,ground,"promise?/o1");
3284 /*_ . Helpers */
3285 /*_ , promise_schedule_eval */
3286 inline pko
3287 promise_schedule_eval(klink * sc, pko p)
3288 {
3289 WITH_REPORTER(sc);
3290 pko guts = unsafe_v2car(p);
3291 pko env = car(cdr(guts));
3292 pko dynxtnt = cdr(cdr(guts));
3293 /* Arrange to eval the expression and pass the result to
3294 handle_promise_result */
3295 CONTIN_1R(dcrry_2ALLVLL,handle_promise_result,sc,p);
3296 /* $$ENCAP ME This deals with continuation guts, so should be
3297 encapped. As a special continuation-maker? */
3298 _kt_spagstack new_dump =
3299 special_dynxtnt (cont_dump(dynxtnt), sc->dump, env);
3300 sc->dump = new_dump;
3301 CONTIN_2(dcrry_2dotALL, kernel_eval, sc, car(guts), env);
3302 return K_INERT;
3303 }
3304 /*_ , handle_promise_result */
3305 SIG_CHKARRAY(handle_promise_result) = { REF_OPER(is_promise), K_ANY };
3306 DEF_SIMPLE_CFUNC(ps0a2,handle_promise_result,0)
3307 {
3308 /* guts are only made by C code so if they're wrong it's a C
3309 error */
3310 WITH_REPORTER(0);
3311 WITH_2_ARGS(p,value);
3312 pko guts = unsafe_v2car(p);
3313
3314 /* if p already has a result, return it */
3315 if(cdr(guts) == K_F)
3316 { return car(guts); }
3317 /* If value is again a promise, set this promise's guts to that
3318 promise's guts and force it again, which will force both (This is
3319 why we need promises to be 2-layer) */
3320 else if(is_promise(value))
3321 {
3322 unsafe_v2set_car (p, unsafe_v2car(value));
3323 return promise_schedule_eval(sc, p);
3324 }
3325 /* Otherwise set the value and return it. */
3326 else
3327 {
3328 unsafe_v2set_car (guts, value);
3329 unsafe_v2set_cdr (guts, K_F);
3330 return value;
3331 }
3332 }
3333 /*_ . Operations */
3334 /*_ , force */
3335 DEF_APPLICATIVE_W_DESTR (ps0a1, force, K_ANY_SINGLETON,T_NO_K,ground,"force")
3336 {
3337 /* guts are only made by this C code here, so if they're wrong it's
3338 a C error */
3339 WITH_REPORTER(0);
3340 WITH_1_ARGS(p);
3341 if(!is_promise(p))
3342 { return p; }
3343
3344 pko guts = unsafe_v2car(p);
3345 if(cdr(guts) == K_F)
3346 { return car(guts); }
3347 else
3348 { return promise_schedule_eval(sc,p); }
3349 }
3350
3351 /*_ , Ports */
3352 /*_ . Creating */
3353
3354 /* $$IMPROVE ME Just directly contain the port structure. Possibly
3355 split port into several T_ types. */
3356 static pko
3357 mk_port (port * pt)
3358 {
3359 ALLOC_BOX_PRESUME (port *, T_PORT);
3360 pbox->data = pt;
3361 return PTR2PKO(pbox);
3362 }
3363
3364 static port *
3365 port_rep_from_filename (const char *fn, int prop)
3366 {
3367 FILE *f;
3368 char *rw;
3369 port *pt;
3370 if (prop == (port_input | port_output))
3371 {
3372 rw = "a+";
3373 }
3374 else if (prop == port_output)
3375 {
3376 rw = "w";
3377 }
3378 else
3379 {
3380 rw = "r";
3381 }
3382 f = fopen (fn, rw);
3383 if (f == 0)
3384 {
3385 return 0;
3386 }
3387 pt = port_rep_from_file (f, prop);
3388 pt->rep.stdio.closeit = 1;
3389
3390 #if SHOW_ERROR_LINE
3391 if (fn)
3392 { pt->rep.stdio.filename = store_string (strlen (fn), fn, 0); }
3393
3394 pt->rep.stdio.curr_line = 0;
3395 #endif
3396 return pt;
3397 }
3398
3399 static pko
3400 port_from_filename (const char *fn, int prop)
3401 {
3402 port *pt;
3403 pt = port_rep_from_filename (fn, prop);
3404 if (pt == 0)
3405 {
3406 return K_NIL;
3407 }
3408 return mk_port (pt);
3409 }
3410
3411 static port *
3412 port_rep_from_file (FILE * f, int prop)
3413 {
3414 port *pt;
3415 pt = (port *) GC_MALLOC_ATOMIC (sizeof *pt);
3416 if (pt == NULL)
3417 {
3418 return NULL;
3419 }
3420 /* Don't care what goes in these but GC really wants to provide it
3421 so here are dummy objects to put it in. */
3422 GC_finalization_proc ofn;
3423 GC_PTR ocd;
3424 GC_register_finalizer(pt, port_finalize_file, 0, &ofn, &ocd);
3425 pt->kind = port_file | prop;
3426 pt->rep.stdio.file = f;
3427 pt->rep.stdio.closeit = 0;
3428 return pt;
3429 }
3430
3431 static pko
3432 port_from_file (FILE * f, int prop)
3433 {
3434 port *pt;
3435 pt = port_rep_from_file (f, prop);
3436 if (pt == 0)
3437 {
3438 return K_NIL;
3439 }
3440 return mk_port (pt);
3441 }
3442
3443 static port *
3444 port_rep_from_string (char *start, char *past_the_end, int prop)
3445 {
3446 port *pt;
3447 pt = (port *) GC_MALLOC_ATOMIC (sizeof (port));
3448 if (pt == 0)
3449 {
3450 return 0;
3451 }
3452 pt->kind = port_string | prop;
3453 pt->rep.string.start = start;
3454 pt->rep.string.curr = start;
3455 pt->rep.string.past_the_end = past_the_end;
3456 return pt;
3457 }
3458
3459 static pko
3460 port_from_string (char *start, char *past_the_end, int prop)
3461 {
3462 port *pt;
3463 pt = port_rep_from_string (start, past_the_end, prop);
3464 if (pt == 0)
3465 {
3466 return K_NIL;
3467 }
3468 return mk_port (pt);
3469 }
3470
3471 #define BLOCK_SIZE 256
3472
3473 static int
3474 realloc_port_string (port * p)
3475 {
3476 /* $$IMPROVE ME Just use REALLOC. */
3477 char *start = p->rep.string.start;
3478 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
3479 char *str = GC_MALLOC_ATOMIC (new_size);
3480 if (str)
3481 {
3482 memset (str, ' ', new_size - 1);
3483 str[new_size - 1] = '\0';
3484 strcpy (str, start);
3485 p->rep.string.start = str;
3486 p->rep.string.past_the_end = str + new_size - 1;
3487 p->rep.string.curr -= start - str;
3488 return 1;
3489 }
3490 else
3491 {
3492 return 0;
3493 }
3494 }
3495
3496
3497 static port *
3498 port_rep_from_scratch (void)
3499 {
3500 port *pt;
3501 char *start;
3502 pt = (port *) GC_MALLOC_ATOMIC (sizeof (port));
3503 if (pt == 0)
3504 {
3505 return 0;
3506 }
3507 start = GC_MALLOC_ATOMIC (BLOCK_SIZE);
3508 if (start == 0)
3509 {
3510 return 0;
3511 }
3512 memset (start, ' ', BLOCK_SIZE - 1);
3513 start[BLOCK_SIZE - 1] = '\0';
3514 pt->kind = port_string | port_output | port_srfi6;
3515 pt->rep.string.start = start;
3516 pt->rep.string.curr = start;
3517 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
3518 return pt;
3519 }
3520
3521 static pko
3522 port_from_scratch (void)
3523 {
3524 port *pt;
3525 pt = port_rep_from_scratch ();
3526 if (pt == 0)
3527 {
3528 return K_NIL;
3529 }
3530 return mk_port (pt);
3531 }
3532 /*_ , Interface */
3533 /*_ . open-input-file */
3534 SIG_CHKARRAY(k_open_input_file) =
3535 { REF_OPER(is_string), };
3536 DEF_SIMPLE_APPLICATIVE(ps0a1,k_open_input_file,0,ground, "open-input-file")
3537 {
3538 WITH_1_ARGS(filename);
3539 return port_from_filename (string_value(filename), port_file | port_input);
3540 }
3541
3542
3543 /*_ . Testing */
3544
3545 DEF_T_PRED (is_port, T_PORT,ground,"port?/o1");
3546
3547 DEF_SIMPLE_PRED (is_inport,T_NO_K,ground,"input-port?/o1")
3548 {
3549 WITH_1_ARGS(p);
3550 return is_port (p) && portvalue (p)->kind & port_input;
3551 }
3552
3553 DEF_SIMPLE_PRED (is_outport,T_NO_K,ground,"output-port?/o1")
3554 {
3555 WITH_1_ARGS(p);
3556 return is_port (p) && portvalue (p)->kind & port_output;
3557 }
3558
3559 /*_ . Values */
3560 INLINE port *
3561 portvalue (pko p)
3562 {
3563 WITH_PSYC_UNBOXED(port *,p,T_PORT,0);
3564 return *pdata;
3565 }
3566
3567 INLINE void
3568 set_portvalue (pko p, port * newport)
3569 {
3570 assert_mutable(0,p);
3571 WITH_PSYC_UNBOXED(port *,p,T_PORT,0);
3572 *pdata = newport;
3573 return;
3574 }
3575
3576 /*_ . reading from ports */
3577 static int
3578 inchar (port *pt)
3579 {
3580 int c;
3581
3582 if (pt->kind & port_saw_EOF)
3583 { return EOF; }
3584 c = basic_inchar (pt);
3585 if (c == EOF)
3586 { pt->kind |= port_saw_EOF; }
3587 #if SHOW_ERROR_LINE
3588 else if (c == '\n')
3589 {
3590 if (pt->kind & port_file)
3591 { pt->rep.stdio.curr_line++; }
3592 }
3593 #endif
3594
3595 return c;
3596 }
3597
3598 static int
3599 basic_inchar (port * pt)
3600 {
3601 if (pt->kind & port_file)
3602 {
3603 return fgetc (pt->rep.stdio.file);
3604 }
3605 else
3606 {
3607 if (*pt->rep.string.curr == 0 ||
3608 pt->rep.string.curr == pt->rep.string.past_the_end)
3609 {
3610 return EOF;
3611 }
3612 else
3613 {
3614 return *pt->rep.string.curr++;
3615 }
3616 }
3617 }
3618
3619 /* back character to input buffer */
3620 static void
3621 backchar (port * pt, int c)
3622 {
3623 if (c == EOF)
3624 { return; }
3625
3626 if (pt->kind & port_file)
3627 {
3628 ungetc (c, pt->rep.stdio.file);
3629 #if SHOW_ERROR_LINE
3630 if (c == '\n')
3631 {
3632 pt->rep.stdio.curr_line--;
3633 }
3634 #endif
3635 }
3636 else
3637 {
3638 if (pt->rep.string.curr != pt->rep.string.start)
3639 {
3640 --pt->rep.string.curr;
3641 }
3642 }
3643 }
3644
3645 /*_ , Interface */
3646
3647 /*_ . (get-char textual-input-port) */
3648 SIG_CHKARRAY(get_char) = { REF_OPER(is_inport), };
3649 DEF_SIMPLE_APPLICATIVE(p00a1,get_char,T_NO_K,ground, "get-char")
3650 {
3651 WITH_1_ARGS(port);
3652 assert(is_inport(port));
3653 int c = inchar(portvalue(port));
3654 if(c == EOF)
3655 { return K_EOF; }
3656 else
3657 { return mk_character(c); }
3658 }
3659
3660 /*_ . Finalization */
3661 static void
3662 port_finalize_file(GC_PTR obj, GC_PTR client_data)
3663 {
3664 port *pt = obj;
3665 if ((pt->kind & port_file) && pt->rep.stdio.closeit)
3666 { port_close_port (pt, port_input | port_output); }
3667 }
3668
3669 static void
3670 port_close (pko p, int flag)
3671 {
3672 assert(is_port(p));
3673 port_close_port(portvalue (p), flag);
3674 }
3675
3676 static void
3677 port_close_port (port * pt, int flag)
3678 {
3679 pt->kind &= ~flag;
3680 if ((pt->kind & (port_input | port_output)) == 0)
3681 {
3682 if (pt->kind & port_file)
3683 {
3684 #if SHOW_ERROR_LINE
3685 /* Cleanup is here so (close-*-port) functions could work too */
3686 pt->rep.stdio.curr_line = 0;
3687
3688 #endif
3689
3690 fclose (pt->rep.stdio.file);
3691 }
3692 pt->kind = port_free;
3693 }
3694 }
3695
3696
3697 /*_ , Encapsulation type */
3698
3699 SIG_CHKARRAY(is_encap) = { REF_OPER(is_key), K_ANY };
3700 DEF_SIMPLE_CFUNC(b00a2, is_encap,T_NO_K)
3701 {
3702 WITH_2_ARGS(type, p);
3703 if (is_type (p, T_ENCAP))
3704 {
3705 WITH_UNBOXED_UNSAFE(pdata,kt_encap,p);
3706 return (pdata->type == type);
3707 }
3708 else
3709 {
3710 return 0;
3711 }
3712 }
3713
3714 /* NOT directly part of the interface. */
3715 SIG_CHKARRAY(unencap) = { REF_OPER(is_key), K_ANY};
3716 DEF_SIMPLE_CFUNC(ps0a2, unencap,T_NO_K)
3717 {
3718 WITH_2_ARGS(type, p);
3719 if (is_encap (type, p))
3720 {
3721 WITH_UNBOXED_UNSAFE(pdata,kt_encap,p);
3722 return pdata->value;
3723 }
3724 else
3725 {
3726 /* We have no type-name to give to the error message. */
3727 KERNEL_ERROR_0 (sc, "unencap: wrong type");
3728 }
3729 }
3730
3731 /* NOT directly part of the interface. */
3732 SIG_CHKARRAY(mk_encap) = { REF_OPER(is_key), K_ANY};
3733 DEF_SIMPLE_CFUNC(p00a2, mk_encap,T_NO_K)
3734 {
3735 WITH_2_ARGS(type, value);
3736 ALLOC_BOX_PRESUME (kt_encap, T_ENCAP);
3737 pbox->data.type = type;
3738 pbox->data.value = value;
3739 return PTR2PKO(pbox);
3740 }
3741
3742 DEF_APPLICATIVE_W_DESTR (p00a0, mk_encapsulation_type, K_NO_TYPE,T_NO_K,ground, "make-encapsulation-type/raw")
3743 {
3744 /* A unique cell representing a type */
3745 pko type = mk_void();
3746 /* $$IMPROVE ME make typespecs for the curried objs. trivpred is
3747 effectively that spec object. */
3748 pko e = wrap (mk_curried (dcrry_2ALLV01, type, REF_OPER (mk_encap)));
3749 pko trivpred = mk_curried (dcrry_2ALLV01, type, REF_OPER (is_encap));
3750 pko d = wrap (mk_curried (dcrry_2ALLV01, type, REF_OPER (unencap)));
3751 return LIST3 (e, trivpred, d);
3752 }
3753 /*_ , Listloop types */
3754 /*_ . Forward declarations */
3755 struct kt_listloop;
3756 /*_ . Enumerations */
3757 /*_ , Next-style */
3758 /* How to turn the current list into current value and next list. */
3759 typedef enum
3760 {
3761 lls_1list,
3762 lls_many,
3763 lls_neighbors,
3764 lls_max,
3765 } kt_loopstyle_step;
3766 typedef enum
3767 {
3768 lls_combiner,
3769 lls_count,
3770 lls_top_count,
3771 lls_stop_on,
3772 lls_num_args,
3773 } kt_loopstyle_argix;
3774
3775 /*_ . Function signatures. */
3776 typedef pko (* kt_listloop_mk_val)(pko value, struct kt_listloop * pll);
3777 /*_ . Struct */
3778 typedef struct kt_listloop_style
3779 {
3780 pko combiner; /* Default combiner or NULL. */
3781 int collect_p; /* Whether to collect a (reversed)
3782 list of the returns. */
3783 kt_loopstyle_step step;
3784 kt_listloop_mk_val mk_val; /* From returned value+state -> passed value. */
3785 pko destructurer; /* A destructurer contents */
3786 /* Selection of args. Each entry correspond to one arg in "full
3787 args", and indexes something in the array of actual args that the
3788 destructurer retrieves. */
3789 int arg_select[lls_num_args];
3790 } kt_listloop_style;
3791 typedef struct kt_listloop
3792 {
3793 pko combiner; /* The combiner to use repeatedly. */
3794 pko list; /* The list to loop over */
3795 int top_length; /* Length of top element, for lls_many. */
3796 int countdown; /* Num elements left, or negative if unused. */
3797 int countup; /* Upwards count from 0. */
3798 pko stop_on; /* Stop if return value is this. Can
3799 be 0 for unused. */
3800 kt_listloop_style * style; /* Non-NULL pointer to style. */
3801 } kt_listloop;
3802
3803 /*_ . Creating */
3804 /*_ , Listloop styles */
3805 /* Unused */
3806 pko
3807 mk_listloop_style
3808 (pko combiner,
3809 int collect_p,
3810 kt_loopstyle_step step,
3811 kt_listloop_mk_val mk_val)
3812 {
3813 ALLOC_BOX_PRESUME(kt_listloop_style,T_LISTLOOP_STYLE);
3814 pdata->combiner = combiner;
3815 pdata->collect_p = collect_p;
3816 pdata->step = step;
3817 pdata->mk_val = mk_val;
3818 return PTR2PKO(pbox);
3819 }
3820 /*_ , Listloops */
3821 pko
3822 mk_listloop
3823 (pko combiner,
3824 pko list,
3825 int top_length,
3826 int count,
3827 pko stop_on,
3828 kt_listloop_style * style)
3829 {
3830 ALLOC_BOX_PRESUME(kt_listloop,T_LISTLOOP);
3831 pdata->combiner = combiner;
3832 pdata->list = list;
3833 pdata->top_length = top_length;
3834 pdata->countdown = count;
3835 pdata->countup = -1;
3836 pdata->stop_on = stop_on;
3837 pdata->style = style;
3838 return PTR2PKO(pbox);
3839 }
3840 /*_ , Copying */
3841 pko
3842 copy_listloop(const kt_listloop * orig)
3843 {
3844 ALLOC_BOX_PRESUME(kt_listloop,T_LISTLOOP);
3845 memcpy (pdata, orig, sizeof(kt_listloop));
3846 return PTR2PKO(pbox);
3847 }
3848 /*_ . Testing */
3849 /* Unused so far */
3850 DEF_T_PRED(is_listloop, T_LISTLOOP, no, "");
3851 DEF_T_PRED(is_listloop_style, T_LISTLOOP_STYLE, no, "");
3852 /*_ . Val-makers */
3853 /*_ . Pre-existing style objects */
3854 /*_ , listloop-style-sequence */
3855 RGSTR(simple,"listloop-style-sequence",REF_OBJ(sequence_style))
3856 static BOX_OF(kt_listloop_style) sequence_style =
3857 {
3858 T_LISTLOOP_STYLE,
3859 {
3860 REF_OPER(kernel_eval),
3861 0,
3862 lls_1list,
3863 0,
3864 K_NO_TYPE, /* No args contemplated */
3865 { [0 ... lls_num_args - 1] = -1, }
3866 }
3867 };
3868 /*_ , listloop-style-neighbors */
3869 RGSTR(simple,"listloop-style-neighbors",REF_OBJ(neighbor_style))
3870 SIG_CHKARRAY(neighbor_style) =
3871 {
3872 REF_OPER(is_integer),
3873 };
3874 DEF_SIMPLE_DESTR(neighbor_style);
3875 static BOX_OF(kt_listloop_style) neighbor_style =
3876 {
3877 T_LISTLOOP_STYLE,
3878 {
3879 REF_OPER(val2val),
3880 1,
3881 lls_neighbors,
3882 0,
3883 REF_DESTR(neighbor_style),
3884 /* See http://gcc.gnu.org/onlinedocs/gcc/Designated-Inits.html. */
3885 { [0 ... lls_num_args - 1] = -1, [lls_count] = 0, },
3886 }
3887 };
3888 /*_ . Operations */
3889 /*_ , listloop */
3890 /* Create a listloop object. */
3891 /* $$IMPROVE ME This may become what style operative calls. Rename
3892 it eval_listloop_style. */
3893 SIG_CHKARRAY(listloop) =
3894 {
3895 REF_OPER(is_listloop_style),
3896 REF_OPER(is_countable_list),
3897 REF_KEY(K_TYCH_DOT),
3898 K_ANY,
3899 };
3900
3901 DEF_SIMPLE_APPLICATIVE(ps0a3, listloop,0,ground, "listloop")
3902 {
3903 WITH_3_ARGS(style, list, args);
3904
3905 WITH_UNBOXED_UNSAFE(style_v,kt_listloop_style, style);
3906 pko style_args[lls_num_args];
3907 /* $$IMPROVE ME If outcome is to be forced, reschedule. Factor
3908 this so that it is possible. */
3909 /* Destructure the args by style */
3910 pko err;
3911 kt_destr_outcome outcome =
3912 destructure_to_array(sc,
3913 args,
3914 style_v->destructurer,
3915 style_args,
3916 lls_num_args,
3917 &err);
3918 if (outcome != destr_success)
3919 {
3920 KERNEL_ERROR_1(sc, "listloop: argobject is the wrong type", err);
3921 }
3922 /*** Get the actual objects ***/
3923 #define GET_OBJ(_INDEX) \
3924 ((style_v->arg_select[_INDEX] < 0) ? K_INERT : style_args[style_v->arg_select[_INDEX]])
3925
3926 pko count = GET_OBJ(lls_count);
3927 pko combiner = GET_OBJ(lls_combiner);
3928 pko top_length = GET_OBJ(lls_top_count);
3929 #undef GET_OBJ
3930
3931 /*** Extract values from the objects, using defaults as needed ***/
3932 int countv = (count == K_INERT) ? -1L : ivalue(count);
3933 int top_lengthv = (top_length == K_INERT) ? 1 : ivalue(top_length);
3934 if(combiner == K_INERT)
3935 {
3936 combiner = style_v->combiner;
3937 }
3938
3939 /*** Make the loop object itself ***/
3940 pko ll = mk_listloop( combiner, list, top_lengthv, countv, 0, style_v );
3941 return ll;
3942 }
3943 /*_ , Evaluating one iteration */
3944 pko
3945 eval_listloop(klink * sc, pko functor, pko value)
3946 {
3947 WITH_REPORTER(sc);
3948 WITH_PSYC_UNBOXED(kt_listloop, functor, T_LISTLOOP, sc);
3949
3950 /*** Test whether done, maybe return current value. ***/
3951 /* If we're not checking, value will be NULL so this won't
3952 trigger. pdata->countup is 0 for the first element. */
3953 if((pdata->countup >= 0) && (value == pdata->stop_on))
3954 {
3955 /* $$IMPROVE ME This will ct an "abnormal return" value from
3956 this and the other data. */
3957 return value;
3958 }
3959 /* If we're not counting down, value will be negative so this won't
3960 trigger. */
3961 if(pdata->countdown == 0)
3962 {
3963 return value;
3964 }
3965 /* And if we run out of elements, we have to stop regardless. */
3966 if(pdata->list == K_NIL)
3967 {
3968 /* $$IMPROVE ME Error if we're counting down (ie, if count
3969 is positive). */
3970 return value;
3971 }
3972
3973 /*** Step list, getting new value ***/
3974 pko new_list, new_value;
3975
3976 switch(pdata->style->step)
3977 {
3978 case lls_1list:
3979 new_list = cdr( pdata->list );
3980 /* We assume the common case of val as list. */
3981 new_value = LIST1(car( pdata->list ));
3982 break;
3983
3984 case lls_neighbors:
3985 /* $$IMPROVE ME Also test that next item (new_list) is non-empty */
3986 new_list = cdr( pdata->list );
3987 new_value = LIST2(car( pdata->list ), car(new_list));
3988 break;
3989 case lls_many:
3990 new_list = k_counted_map_cdr(sc, pdata->top_length, pdata->list, T_PAIR);
3991 new_value = k_counted_map_car(sc, pdata->top_length, pdata->list, T_PAIR);
3992 break;
3993 default:
3994 KERNEL_ERROR_0(sc,"I know nut-ting about that case");
3995 }
3996
3997 /* Convert it if applicable. */
3998 if(pdata->style->mk_val)
3999 {
4000 new_value = pdata->style->mk_val(new_value, pdata);
4001 }
4002
4003 /*** Arrange a new iteration. ***/
4004 /* We don't have to re-setup the final chain, if any, because it's
4005 still there from the earlier call. Just the combiner (if any)
4006 and a fresh listloop operative. */
4007 pko new_listloop = copy_listloop(pdata);
4008 {
4009 WITH_UNBOXED_UNSAFE(new_pdata,kt_listloop,new_listloop);
4010 new_pdata->list = new_list;
4011 if(new_pdata->countdown > 0)
4012 { new_pdata->countdown--; }
4013 new_pdata->countup++;
4014 }
4015
4016 if(pdata->style->collect_p)
4017 {
4018 CONTIN_0_RAW (mk_curried(dcrry_NVLLdotALL, value, new_listloop), sc);
4019 }
4020 else
4021 {
4022 CONTIN_0_RAW(new_listloop, sc);
4023 }
4024
4025 CONTIN_0_RAW(pdata->combiner, sc);
4026 return new_value;
4027 }
4028
4029 /*_ . Handling lists */
4030 /*_ , list* */
4031 DEF_APPLICATIVE_W_DESTR (ps0a1, list_star, REF_OPER(is_finite_list),T_NO_K,ground, "list*")
4032 {
4033 return v2list_star(sc, arg1, T_PAIR);
4034 }
4035 /*_ , reverse */
4036 SIG_CHKARRAY(reverse) = { REF_OPER(is_finite_list), };
4037 DEF_SIMPLE_APPLICATIVE (ps0a1, reverse,T_NO_K,ground, "reverse")
4038 {
4039 WITH_1_ARGS(a);
4040 return v2reverse(a,T_PAIR);
4041 }
4042 /*_ . reverse list -- in-place */
4043 /* Don't just use unsafe_v2reverse_in_place, it checks nothing. This
4044 may be reserved for optimization only. */
4045
4046 /*_ . append list -- produce new list */
4047 /* $$IMPROVE ME This defines append/2 but we'll want append/N. Do
4048 that in init. */
4049 SIG_CHKARRAY(append) = { REF_OPER(is_finite_list), K_ANY, };
4050 DEF_SIMPLE_APPLICATIVE (ps0a2, append,T_NO_K,simple, "append")
4051 {
4052 WITH_2_ARGS(a,b);
4053 return v2append(sc,a,b,T_PAIR);
4054 }
4055 /*_ , is_finite_list */
4056 DEF_SIMPLE_PRED (is_finite_list,T_NO_K,ground, "finite-list?/o1")
4057 {
4058 WITH_1_ARGS(p);
4059 int4 metrics;
4060 get_list_metrics_aux(p, metrics);
4061 return (metrics[lm_num_nils] == 1);
4062 }
4063 /*_ , is_countable_list */
4064 DEF_SIMPLE_PRED (is_countable_list,T_NO_K,ground, "countable-list?/o1")
4065 {
4066 WITH_1_ARGS(p);
4067 int4 metrics;
4068 get_list_metrics_aux(p, metrics);
4069 return (metrics[lm_num_nils] || metrics[lm_cyc_len]);
4070 }
4071 /*_ , list_length */
4072 /* Result is:
4073 proper list: length
4074 circular list: -1
4075 not even a pair: -2
4076 dotted list: -2 minus length before dot
4077
4078 The extra meanings will change since callers can use
4079 get_list_metrics_aux now. Return lm_acyc_len even for dotted
4080 lists, return positive infinity for circular lists.
4081 */
4082 /* $$OBSOLESCENT */
4083 int
4084 list_length (pko p)
4085 {
4086 int4 metrics;
4087 get_list_metrics_aux(p, metrics);
4088 /* A proper list */
4089 if(metrics[lm_num_nils] == 1)
4090 { return metrics[lm_acyc_len]; }
4091 /* A circular list */
4092 /* $$IMPROVE ME Return +oo. First make a type and object for +oo */
4093 if(metrics[lm_cyc_len] != 0)
4094 { return -1; }
4095 /* $$IMPROVE ME Return lm_acyc_len again, merge with the other
4096 case. */
4097 /* Otherwise it's dotted */
4098 return 2 - metrics[lm_acyc_len];
4099 }
4100 /*_ , list_length_k */
4101 DEF_APPLICATIVE_W_DESTR(p00a1, list_length_k, K_ANY_SINGLETON,T_NO_K,ground, "length")
4102 {
4103 WITH_1_ARGS(p);
4104 return mk_integer(list_length(p));
4105 }
4106
4107 /*_ , get_list_metrics */
4108 DEF_APPLICATIVE_W_DESTR(p00a1, get_list_metrics, K_ANY_SINGLETON,T_NO_K,ground, "get-list-metrics")
4109 {
4110 WITH_1_ARGS(p);
4111 int4 metrics;
4112 get_list_metrics_aux(p, metrics);
4113 return LIST4(mk_integer(metrics[0]),
4114 mk_integer(metrics[1]),
4115 mk_integer(metrics[2]),
4116 mk_integer(metrics[3]));
4117 }
4118 /*_ , get_list_metrics_aux */
4119 /* RESULTS must be an int4 (an array of 4 integers). get_list_metrics_aux
4120 will fill it with (See enum lm_index):
4121
4122 * the number of pairs in a
4123 * the number of nil objects in a
4124 * the acyclic prefix length of a
4125 * the cycle length of a
4126 */
4127
4128 /* $$IMPROVE ME Take a flag so we can skip work such as finding
4129 prefix-length when we don't need to do it. This will cause some
4130 result positions to be interpreted differently: when it's cycling,
4131 lm_acyc_len and lm_num_pairs may both overshoot (but never
4132 undershoot).
4133 */
4134
4135 void
4136 get_list_metrics_aux (pko a, int4 presults)
4137 {
4138 int * results = presults; /* Make it easier to index. */
4139 int steps = 0;
4140 int power = 1;
4141 int loop_len = 1;
4142 pko slow, fast;
4143 WITH_REPORTER(0);
4144
4145 /* Use Brent's Algorithm, but we have to check for nil and non-pair
4146 too, so I rearranged the loop. We also count steps, because in
4147 some cases we use number of steps directly. */
4148 slow = fast = a;
4149 while (1)
4150 {
4151 if (fast == K_NIL)
4152 {
4153 results[lm_num_pairs] = steps;
4154 results[lm_num_nils] = 1;
4155 results[lm_acyc_len] = steps;
4156 results[lm_cyc_len] = 0;
4157 return;
4158 }
4159 if (!is_pair (fast))
4160 {
4161 results[lm_num_pairs] = steps;
4162 results[lm_num_nils] = 0;
4163 results[lm_acyc_len] = steps;
4164 results[lm_cyc_len] = 0;
4165 return;
4166 }
4167 fast = cdr (fast);
4168 if (fast == slow)
4169 {
4170 /* The fast cursor has caught up with the slow cursor so the
4171 structure is circular and loop_len is the cycle length.
4172 We still need to find prefix length.
4173 */
4174 int prefix_len = 0;
4175 int i = 0;
4176 /* Restart the turtle from the beginning */
4177 slow = a;
4178 /* Restart the hare from position LOOP_LEN */
4179 for(i = 0, fast = a; i < loop_len; i++)
4180 { fast = cdr (fast); }
4181 /* Since hare has exactly a loop_len head start, when it
4182 goes around the loop exactly once it will be in the same
4183 position as turtle, so turtle will have only walked the
4184 acyclic prefix. */
4185 while(fast != slow)
4186 {
4187 fast = cdr (fast);
4188 slow = cdr (slow);
4189 prefix_len++;
4190 }
4191
4192 results[lm_num_pairs] = prefix_len + loop_len;
4193 results[lm_num_nils] = 0;
4194 results[lm_acyc_len] = prefix_len;
4195 results[lm_cyc_len] = loop_len;
4196 return;
4197 }
4198 if(power == loop_len)
4199 {
4200 /* Re-plant the slow cursor */
4201 slow = fast;
4202 loop_len = 0;
4203 power *= 2;
4204 }
4205 ++loop_len;
4206 ++steps;
4207 }
4208 }
4209 /*_ . Handling trees */
4210 /*_ , copy_es_immutable */
4211 DEF_APPLICATIVE_W_DESTR (ps0a1, copy_es_immutable, K_ANY_SINGLETON,T_NO_K,ground, "copy-es-immutable")
4212 {
4213 WITH_1_ARGS(object);
4214 WITH_REPORTER(sc);
4215 if (is_pair (object))
4216 {
4217 /* If it's already immutable, can we assume it's immutable
4218 * all the way down and just return it? */
4219 return cons
4220 (copy_es_immutable (sc, car (object)),
4221 copy_es_immutable (sc, cdr (object)));
4222 }
4223 else
4224 {
4225 return object;
4226 }
4227 }
4228 /*_ , Get tree cycles */
4229 /*_ . Structs */
4230 /*_ , kt_recurrence_table */
4231 /* Really just a specialized resizeable lookup table from object to
4232 count. Internals may change. */
4233 /* $$IMPROVE ME Look up more efficiently. Current GC is not
4234 compacting, so we can hash or sort addresses meaningfully. */
4235 typedef struct
4236 {
4237 pko * objs;
4238 int * counts;
4239 int table_size;
4240 int alloced_size;
4241 }
4242 kt_recurrence_table;
4243 /*_ , recur_entry */
4244 typedef struct
4245 {
4246 /* $$IMPROVE ME These two fields may become one enumerated field */
4247 int count;
4248 int seen_in_walk;
4249 int index_in_walk;
4250 } recur_entry;
4251 /*_ , kt_recur_tracker */
4252 typedef struct
4253 {
4254 pko * objs;
4255 recur_entry * entries;
4256 int table_size;
4257 int current_index;
4258 } kt_recur_tracker;
4259 /*_ . is_recurrence_table */
4260 DEF_T_PRED(is_recurrence_table,T_RECURRENCES,ground, "recurrence-table?/o1");
4261
4262 /*_ . is_recur_tracker */
4263 DEF_SIMPLE_PRED(is_recur_tracker,T_NO_K,ground, "recur-tracker?/o1")
4264 {
4265 WITH_1_ARGS(p);
4266 return (p == K_NIL) || is_type (p, T_RECUR_TRACKER);
4267 }
4268 /*_ . recurrences_to_recur_tracker */
4269 SIG_CHKARRAY(recurrences_to_recur_tracker) =
4270 { REF_OPER(is_recurrence_table), };
4271 DEF_SIMPLE_APPLICATIVE(p00a1,recurrences_to_recur_tracker,T_NO_K,ground, "recurrences->tracker")
4272 {
4273 WITH_1_ARGS(recurrences);
4274 assert_type(0,recurrences,T_RECURRENCES);
4275
4276 WITH_UNBOXED_UNSAFE(ptable, kt_recurrence_table,recurrences);
4277 /* $$IMPROVE ME Scan for counts > 1, and if there are none,
4278 return K_NIL. */
4279 if(ptable->table_size == 0)
4280 { return K_NIL; }
4281 {
4282 ALLOC_BOX_PRESUME(kt_recur_tracker,T_RECUR_TRACKER);
4283 /* $$MAKE ME SAFE This assumes that sharing is OK, recurrences
4284 won't mutate the LUT. When we have COW or similar, make it
4285 safe. At least check for immutability. */
4286 pdata->objs = ptable->objs;
4287 pdata->table_size = ptable->table_size;
4288 pdata->current_index = 0;
4289 pdata->entries =
4290 GC_MALLOC_ATOMIC(sizeof(recur_entry) * ptable->table_size);
4291 int i;
4292 for(i = 0; i < ptable->table_size; i++)
4293 {
4294 recur_entry * p_entry = &pdata->entries[i];
4295 p_entry->count = ptable->counts[i];
4296 p_entry->index_in_walk = 0;
4297 p_entry->seen_in_walk = 0;
4298 }
4299 return PTR2PKO(pbox);
4300 }
4301 }
4302 /*_ . recurrences_list_objects */
4303 /* $$WRITE ME Get a list of all objects and their recurrence counts */
4304 /*_ . objtable_get_index */
4305 int
4306 objtable_get_index
4307 (pko * objs, int table_size, pko obj)
4308 {
4309 int i;
4310 for(i = 0; i < table_size; i++)
4311 {
4312 if(obj == objs[i])
4313 { return i; }
4314 }
4315 return -1;
4316 }
4317 /*_ . recurrences_get_seen_count */
4318 /* Return the number of times OBJ has been seen before. If "add" is
4319 non-zero, increment the count too (but return its previous
4320 value). */
4321 int
4322 recurrences_get_seen_count
4323 (kt_recurrence_table * p_cycles_data, pko obj, int add)
4324 {
4325 int index = objtable_get_index(p_cycles_data->objs,
4326 p_cycles_data->table_size,
4327 obj);
4328 if(index >= 0)
4329 {
4330 int count = p_cycles_data->counts[index];
4331 /* Maybe record another sighting of this object. */
4332 if(add)
4333 { p_cycles_data->counts[index]++; }
4334 /* We've found our return value. */
4335 return count;
4336 }
4337
4338 /* We only get here if search didn't find anything. */
4339 /* Make sure we have enough space for this object. */
4340 if(add)
4341 {
4342 if(p_cycles_data->table_size == p_cycles_data->alloced_size)
4343 {
4344 p_cycles_data->alloced_size *= 2;
4345 p_cycles_data->counts = GC_REALLOC(p_cycles_data->counts, sizeof(int) * p_cycles_data->alloced_size);
4346 p_cycles_data->objs = GC_REALLOC(p_cycles_data->objs, sizeof(pko) * p_cycles_data->alloced_size);
4347 }
4348 int index = p_cycles_data->table_size;
4349 /* Record what it was */
4350 p_cycles_data->objs[index] = obj;
4351 /* We have now seen it once. */
4352 p_cycles_data->counts[index] = 1;
4353 p_cycles_data->table_size++;
4354 }
4355 return 0;
4356 }
4357 /*_ . recurrences_get_object_count */
4358 /* Given an object, list its count */
4359 SIG_CHKARRAY(recurrences_get_object_count) =
4360 { REF_OPER(is_recurrence_table), K_ANY, };
4361 DEF_SIMPLE_APPLICATIVE(p00a2, recurrences_get_object_count,T_NO_K,ground, "recurrences-get-object-count")
4362 {
4363 WITH_2_ARGS(table, obj);
4364 WITH_PSYC_UNBOXED(kt_recurrence_table,table, T_RECURRENCES, 0);
4365 int seen_count = recurrences_get_seen_count(pdata, obj, 0);
4366 return mk_integer(seen_count);
4367 }
4368 /*_ . init_recurrence_table */
4369 void
4370 init_recurrence_table(kt_recurrence_table * p_cycles_data, int initial_size)
4371 {
4372 p_cycles_data->objs = initial_size ?
4373 GC_MALLOC(sizeof(pko) * initial_size) : 0;
4374 p_cycles_data->counts = initial_size ?
4375 GC_MALLOC(sizeof(int) * initial_size) : 0;
4376 p_cycles_data->alloced_size = initial_size;
4377 p_cycles_data->table_size = 0;
4378 }
4379 /*_ . trace_tree_cycles */
4380 static void
4381 trace_tree_cycles
4382 (pko tree, kt_recurrence_table * p_cycles_data)
4383 {
4384 /* Special case for the "empty container", not because it's just a
4385 key but because "exploring" it does nothing. */
4386 if (tree == K_NIL)
4387 { return; }
4388 /* Maybe skip this object entirely */
4389 /* $$IMPROVE ME Parameterize this */
4390 switch(_get_type(tree))
4391 {
4392 case T_SYMBOL:
4393 case T_NUMBER:
4394 return;
4395 default:
4396 break;
4397 }
4398 if(recurrences_get_seen_count(p_cycles_data,tree, 1) != 0)
4399 { return; }
4400
4401 /* Switch on tree type */
4402 switch(_get_type(tree))
4403 {
4404 case T_PAIR:
4405 {
4406 #define _EXPLORE_FUNC(X) trace_tree_cycles(X, p_cycles_data)
4407 EXPLORE_v2(tree);
4408 #undef _EXPLORE_FUNC
4409 break;
4410 }
4411 default:
4412 break;
4413 /* Done this exploration */
4414 }
4415 return;
4416 }
4417
4418 /*_ . get_recurrences */
4419 SIG_CHKARRAY(get_recurrences) = { K_ANY, };
4420 DEF_SIMPLE_APPLICATIVE (ps0a1, get_recurrences,T_NO_K,ground, "get-recurrences")
4421 {
4422 WITH_1_ARGS(tree);
4423 /* No reason to even start exploring non-containers */
4424 /* $$IMPROVE ME Allow containers other than pairs */
4425 int explore_p = (_get_type(tree) == T_PAIR);
4426 ALLOC_BOX_PRESUME(kt_recurrence_table, T_RECURRENCES);
4427 init_recurrence_table(pdata, explore_p ? 8 : 0);
4428 if(explore_p)
4429 { trace_tree_cycles(tree,pdata); }
4430 return PTR2PKO(pbox);
4431 }
4432
4433 /*_ . Reading */
4434
4435 /*_ , Making result objects */
4436
4437 /* make symbol or number atom from string */
4438 static pko
4439 mk_atom (klink * sc, char *q)
4440 {
4441 char c, *p;
4442 int has_dec_point = 0;
4443 int has_fp_exp = 0;
4444
4445 #if USE_COLON_HOOK
4446 if ((p = strstr (q, "::")) != 0)
4447 {
4448 *p = 0;
4449 return mcons (sc->COLON_HOOK,
4450 mcons (mcons (sc->QUOTE,
4451 mcons (mk_atom (sc, p + 2), K_NIL)),
4452 mcons (mk_symbol (strlwr (q)), K_NIL)));
4453 }
4454 #endif
4455
4456 p = q;
4457 c = *p++;
4458 if ((c == '+') || (c == '-'))
4459 {
4460 c = *p++;
4461 if (c == '.')
4462 {
4463 has_dec_point = 1;
4464 c = *p++;
4465 }
4466 if (!isdigit (c))
4467 {
4468 return (mk_symbol (strlwr (q)));
4469 }
4470 }
4471 else if (c == '.')
4472 {
4473 has_dec_point = 1;
4474 c = *p++;
4475 if (!isdigit (c))
4476 {
4477 return (mk_symbol (strlwr (q)));
4478 }
4479 }
4480 else if (!isdigit (c))
4481 {
4482 return (mk_symbol (strlwr (q)));
4483 }
4484
4485 for (; (c = *p) != 0; ++p)
4486 {
4487 if (!isdigit (c))
4488 {
4489 if (c == '.')
4490 {
4491 if (!has_dec_point)
4492 {
4493 has_dec_point = 1;
4494 continue;
4495 }
4496 }
4497 else if ((c == 'e') || (c == 'E'))
4498 {
4499 if (!has_fp_exp)
4500 {
4501 has_dec_point = 1; /* decimal point illegal
4502 from now on */
4503 p++;
4504 if ((*p == '-') || (*p == '+') || isdigit (*p))
4505 {
4506 continue;
4507 }
4508 }
4509 }
4510 return (mk_symbol (strlwr (q)));
4511 }
4512 }
4513 if (has_dec_point)
4514 {
4515 return mk_real (atof (q));
4516 }
4517 return (mk_integer (atol (q)));
4518 }
4519
4520 /* make constant */
4521 static pko
4522 mk_sharp_const (char *name)
4523 {
4524 long x;
4525 char tmp[STRBUFFSIZE];
4526
4527 if (!strcmp (name, "t"))
4528 return (K_T);
4529 else if (!strcmp (name, "f"))
4530 return (K_F);
4531 else if (!strcmp (name, "ignore"))
4532 return (K_IGNORE);
4533 else if (!strcmp (name, "inert"))
4534 return (K_INERT);
4535 else if (*name == 'o')
4536 { /* #o (octal) */
4537 snprintf (tmp, STRBUFFSIZE, "0%s", name + 1);
4538 sscanf (tmp, "%lo", &x);
4539 return (mk_integer (x));
4540 }
4541 else if (*name == 'd')
4542 { /* #d (decimal) */
4543 sscanf (name + 1, "%ld", &x);
4544 return (mk_integer (x));
4545 }
4546 else if (*name == 'x')
4547 { /* #x (hex) */
4548 snprintf (tmp, STRBUFFSIZE, "0x%s", name + 1);
4549 sscanf (tmp, "%lx", &x);
4550 return (mk_integer (x));
4551 }
4552 else if (*name == 'b')
4553 { /* #b (binary) */
4554 x = binary_decode (name + 1);
4555 return (mk_integer (x));
4556 }
4557 else if (*name == '\\')
4558 { /* #\w (character) */
4559 int c = 0;
4560 if (stricmp (name + 1, "space") == 0)
4561 {
4562 c = ' ';
4563 }
4564 else if (stricmp (name + 1, "newline") == 0)
4565 {
4566 c = '\n';
4567 }
4568 else if (stricmp (name + 1, "return") == 0)
4569 {
4570 c = '\r';
4571 }
4572 else if (stricmp (name + 1, "tab") == 0)
4573 {
4574 c = '\t';
4575 }
4576 else if (name[1] == 'x' && name[2] != 0)
4577 {
4578 int c1 = 0;
4579 if (sscanf (name + 2, "%x", &c1) == 1 && c1 < UCHAR_MAX)
4580 {
4581 c = c1;
4582 }
4583 else
4584 {
4585 return K_NIL;
4586 }
4587 #if USE_ASCII_NAMES
4588 }
4589 else if (is_ascii_name (name + 1, &c))
4590 {
4591 /* nothing */
4592 #endif
4593 }
4594 else if (name[2] == 0)
4595 {
4596 c = name[1];
4597 }
4598 else
4599 {
4600 return K_NIL;
4601 }
4602 return mk_character (c);
4603 }
4604 else
4605 return (K_NIL);
4606 }
4607
4608 /*_ , Reading strings */
4609 /* read characters up to delimiter, but cater to character constants */
4610 static char *
4611 readstr_upto (klink * sc, char *delim)
4612 {
4613 port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
4614
4615 char *p = sc->strbuff;
4616
4617 while ((p - sc->strbuff < sizeof (sc->strbuff)) &&
4618 !is_one_of (delim, (*p++ = inchar (pt))));
4619
4620 if (p == sc->strbuff + 2 && p[-2] == '\\')
4621 {
4622 *p = 0;
4623 }
4624 else
4625 {
4626 backchar (pt, p[-1]);
4627 *--p = '\0';
4628 }
4629 return sc->strbuff;
4630 }
4631
4632 /* skip white characters */
4633 static INLINE int
4634 skipspace (klink * sc)
4635 {
4636 port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
4637 int c = 0;
4638
4639 do
4640 { c = inchar (pt); }
4641 while (isspace (c));
4642 if (c != EOF)
4643 {
4644 backchar (pt, c);
4645 return 1;
4646 }
4647 else
4648 { return EOF; }
4649 }
4650
4651 /*_ , Utilities */
4652 /* check c is in chars */
4653 static INLINE int
4654 is_one_of (char *s, int c)
4655 {
4656 if (c == EOF)
4657 return 1;
4658 while (*s)
4659 if (*s++ == c)
4660 return (1);
4661 return (0);
4662 }
4663
4664 /*_ , Reading expressions */
4665 /* read string expression "xxx...xxx" */
4666 static pko
4667 readstrexp (klink * sc)
4668 {
4669 port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
4670 char *p = sc->strbuff;
4671 int c;
4672 int c1 = 0;
4673 enum
4674 { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
4675
4676 for (;;)
4677 {
4678 c = inchar (pt);
4679 if (c == EOF || p - sc->strbuff > sizeof (sc->strbuff) - 1)
4680 {
4681 return K_F;
4682 }
4683 switch (state)
4684 {
4685 case st_ok:
4686 switch (c)
4687 {
4688 case '\\':
4689 state = st_bsl;
4690 break;
4691 case '"':
4692 *p = 0;
4693 return mk_counted_string (sc->strbuff, p - sc->strbuff);
4694 default:
4695 *p++ = c;
4696 break;
4697 }
4698 break;
4699 case st_bsl:
4700 switch (c)
4701 {
4702 case '0':
4703 case '1':
4704 case '2':
4705 case '3':
4706 case '4':
4707 case '5':
4708 case '6':
4709 case '7':
4710 state = st_oct1;
4711 c1 = c - '0';
4712 break;
4713 case 'x':
4714 case 'X':
4715 state = st_x1;
4716 c1 = 0;
4717 break;
4718 case 'n':
4719 *p++ = '\n';
4720 state = st_ok;
4721 break;
4722 case 't':
4723 *p++ = '\t';
4724 state = st_ok;
4725 break;
4726 case 'r':
4727 *p++ = '\r';
4728 state = st_ok;
4729 break;
4730 case '"':
4731 *p++ = '"';
4732 state = st_ok;
4733 break;
4734 default:
4735 *p++ = c;
4736 state = st_ok;
4737 break;
4738 }
4739 break;
4740 case st_x1:
4741 case st_x2:
4742 c = toupper (c);
4743 if (c >= '0' && c <= 'F')
4744 {
4745 if (c <= '9')
4746 {
4747 c1 = (c1 << 4) + c - '0';
4748 }
4749 else
4750 {
4751 c1 = (c1 << 4) + c - 'A' + 10;
4752 }
4753 if (state == st_x1)
4754 {
4755 state = st_x2;
4756 }
4757 else
4758 {
4759 *p++ = c1;
4760 state = st_ok;
4761 }
4762 }
4763 else
4764 {
4765 return K_F;
4766 }
4767 break;
4768 case st_oct1:
4769 case st_oct2:
4770 if (c < '0' || c > '7')
4771 {
4772 *p++ = c1;
4773 backchar (pt, c);
4774 state = st_ok;
4775 }
4776 else
4777 {
4778 if (state == st_oct2 && c1 >= 32)
4779 return K_F;
4780
4781 c1 = (c1 << 3) + (c - '0');
4782
4783 if (state == st_oct1)
4784 state = st_oct2;
4785 else
4786 {
4787 *p++ = c1;
4788 state = st_ok;
4789 }
4790 }
4791 break;
4792
4793 }
4794 }
4795 }
4796
4797
4798 /* get token */
4799 static int
4800 token (klink * sc)
4801 {
4802 port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
4803 int c;
4804 c = skipspace (sc);
4805 if (c == EOF)
4806 {
4807 return (TOK_EOF);
4808 }
4809 switch (c = inchar (pt))
4810 {
4811 case EOF:
4812 return (TOK_EOF);
4813 case '(':
4814 return (TOK_LPAREN);
4815 case ')':
4816 return (TOK_RPAREN);
4817 case '.':
4818 c = inchar (pt);
4819 if (is_one_of (" \n\t", c))
4820 {
4821 return (TOK_DOT);
4822 }
4823 else
4824 {
4825 backchar (pt, c);
4826 backchar (pt, '.');
4827 return TOK_ATOM;
4828 }
4829 case '\'':
4830 return (TOK_QUOTE);
4831 case ';':
4832 while ((c = inchar (pt)) != '\n' && c != EOF)
4833 {}
4834
4835 if (c == EOF)
4836 {
4837 return (TOK_EOF);
4838 }
4839 else
4840 {
4841 return (token (sc));
4842 }
4843 case '"':
4844 return (TOK_DQUOTE);
4845 case '`':
4846 return (TOK_BQUOTE);
4847 case ',':
4848 if ((c = inchar (pt)) == '@')
4849 {
4850 return (TOK_ATMARK);
4851 }
4852 else
4853 {
4854 backchar (pt, c);
4855 return (TOK_COMMA);
4856 }
4857 case '#':
4858 c = inchar (pt);
4859 if (c == '(')
4860 {
4861 return (TOK_VEC);
4862 }
4863 else if (c == '!')
4864 {
4865 while ((c = inchar (pt)) != '\n' && c != EOF)
4866 {}
4867
4868 if (c == EOF)
4869 {
4870 return (TOK_EOF);
4871 }
4872 else
4873 {
4874 return (token (sc));
4875 }
4876 }
4877 else
4878 {
4879 backchar (pt, c);
4880 /* $$UNHACKIFY ME! This is a horrible hack. */
4881 if (is_one_of (" itfodxb\\", c))
4882 {
4883 return TOK_SHARP_CONST;
4884 }
4885 else
4886 {
4887 return (TOK_SHARP);
4888 }
4889 }
4890 default:
4891 backchar (pt, c);
4892 return (TOK_ATOM);
4893 }
4894 }
4895 /*_ , Nesting check */
4896 /*_ . create_nesting_check */
4897 void create_nesting_check(klink * sc)
4898 { klink_push_dyn_binding(sc,K_NEST_DEPTH,mk_integer(0)); }
4899 /*_ . nest_depth_ok_p */
4900 int nest_depth_ok_p(klink * sc)
4901 {
4902 pko nesting =
4903 klink_find_dyn_binding(sc,K_NEST_DEPTH);
4904 if(!nesting)
4905 { return 1; }
4906 return ivalue(nesting) == 0;
4907 }
4908 /*_ . change_nesting_depth */
4909 void change_nesting_depth(klink * sc, signed int change)
4910 {
4911 pko nesting =
4912 klink_find_dyn_binding(sc,K_NEST_DEPTH);
4913 add_to_ivalue(nesting,change);
4914 }
4915 /*_ , C-style entry points */
4916
4917 /*_ . kernel_read_internal */
4918 /* The only reason that this is separate from kernel_read_sexp is that
4919 it gets a token, which kernel_read_sexp does almost always, except
4920 once when a caller tricks it with TOK_LPAREN, and once when
4921 kernel_read_list effectively puts back a token it didn't decode. */
4922 static
4923 DEF_APPLICATIVE_W_DESTR (ps0a0, kernel_read_internal, K_NO_TYPE,0,ground, "read")
4924 {
4925 token_t tok = token (sc);
4926 if (tok == TOK_EOF)
4927 {
4928 return K_EOF;
4929 }
4930 sc->tok = tok;
4931 create_nesting_check(sc);
4932 return kernel_read_sexp (sc);
4933 }
4934
4935 /*_ . kernel_read_sexp */
4936 DEF_CFUNC (ps0a0, kernel_read_sexp, K_NO_TYPE,0)
4937 {
4938 switch (sc->tok)
4939 {
4940 case TOK_EOF:
4941 return K_EOF;
4942 /* NOTREACHED */
4943 case TOK_VEC:
4944 CONTIN_0 (vector, sc);
4945
4946 /* fall through */
4947 case TOK_LPAREN:
4948 sc->tok = token (sc);
4949 if (sc->tok == TOK_RPAREN)
4950 {
4951 return K_NIL;
4952 }
4953 else if (sc->tok == TOK_DOT)
4954 {
4955 KERNEL_ERROR_0 (sc, "syntax error: illegal dot expression");
4956 }
4957 else
4958 {
4959 change_nesting_depth(sc, 1);
4960 CONTIN_1 (dcrry_2A01VLL, kernel_read_list, sc, K_NIL);
4961 CONTIN_0 (kernel_read_sexp, sc);
4962 return K_INERT;
4963 }
4964 case TOK_QUOTE:
4965 {
4966 pko pquote = REF_OPER(arg1);
4967 CONTIN_1 (dcrry_2A01VLL, val2val, sc, pquote);
4968 }
4969 sc->tok = token (sc);
4970 CONTIN_0 (kernel_read_sexp, sc);
4971 return K_INERT;
4972
4973 case TOK_BQUOTE:
4974 sc->tok = token (sc);
4975 if (sc->tok == TOK_VEC)
4976 {
4977 /* $$CLEAN ME Do this more cleanly than by changing tokens
4978 to trick it. Maybe factor the TOK_LPAREN treatment so we
4979 can schedule it. */
4980 klink_push_cont (sc, REF_OPER (kernel_treat_qquoted_vec));
4981 sc->tok = TOK_LPAREN;
4982 /* $$CLEANUP Seems like this could be combined with the part
4983 afterwards */
4984 CONTIN_0 (kernel_read_sexp, sc);
4985 return K_INERT;
4986 }
4987 else
4988 {
4989 /* Punt for now: Give quoted symbols rather than actual
4990 operators. ,Similarly sc->UNQUOTE, sc->UNQUOTESP */
4991 CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->QQUOTE);
4992 }
4993
4994 CONTIN_0 (kernel_read_sexp, sc);
4995 return K_INERT;
4996
4997 case TOK_COMMA:
4998 CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->UNQUOTE);
4999 sc->tok = token (sc);
5000 CONTIN_0 (kernel_read_sexp, sc);
5001 return K_INERT;
5002 case TOK_ATMARK:
5003 CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->UNQUOTESP);
5004 sc->tok = token (sc);
5005 CONTIN_0 (kernel_read_sexp, sc);
5006 return K_INERT;
5007 case TOK_ATOM:
5008 return mk_atom (sc, readstr_upto (sc, "();\t\n\r "));
5009 case TOK_DQUOTE:
5010 {
5011 pko x = readstrexp (sc);
5012 if (x == K_F)
5013 {
5014 KERNEL_ERROR_0 (sc, "Error reading string");
5015 }
5016 setimmutable (x);
5017 return x;
5018 }
5019 case TOK_SHARP:
5020 {
5021 pko sharp_hook = sc->SHARP_HOOK;
5022 pko f =
5023 is_symbol(sharp_hook)
5024 ? find_slot_in_env (sc->envir, sharp_hook, 1)
5025 : K_NIL;
5026 if (f == 0)
5027 {
5028 KERNEL_ERROR_0 (sc, "undefined sharp expression");
5029 }
5030 else
5031 {
5032 pko form = mcons (slot_value_in_env (f), K_NIL);
5033 return kernel_eval (sc, form, sc->envir);
5034 }
5035 }
5036 case TOK_SHARP_CONST:
5037 {
5038 pko x = mk_sharp_const (readstr_upto (sc, "();\t\n\r "));
5039 if (x == K_NIL)
5040 {
5041 KERNEL_ERROR_0 (sc, "undefined sharp expression");
5042 }
5043 else
5044 {
5045 return x;
5046 }
5047 }
5048 default:
5049 KERNEL_ERROR_0 (sc, "syntax error: illegal token");
5050 }
5051 }
5052
5053 /*_ . Read list */
5054 /* $$IMPROVE ME Use currying ops instead of accumulating by hand */
5055 SIG_CHKARRAY(kernel_read_list) = { REF_OPER(is_finite_list), K_ANY, };
5056 DEF_SIMPLE_CFUNC (ps0a2, kernel_read_list,0)
5057 {
5058 WITH_2_ARGS (old_accum,value);
5059 pko accum = mcons (value, old_accum);
5060 port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5061 sc->tok = token (sc);
5062 if (sc->tok == TOK_EOF)
5063 {
5064 return (K_EOF);
5065 }
5066 else if (sc->tok == TOK_RPAREN)
5067 {
5068 /* $$RECONSIDER ME Why is this done? To accept CR from user? */
5069 int c = inchar (pt);
5070 if (c != '\n')
5071 {
5072 backchar (pt, c);
5073 }
5074 change_nesting_depth(sc, -1);
5075 return (unsafe_v2reverse_in_place (K_NIL, accum));
5076 }
5077 else if (sc->tok == TOK_DOT)
5078 {
5079 CONTIN_1 (dcrry_2A01VLL, kernel_treat_dotted_list, sc, accum);
5080 sc->tok = token (sc);
5081 CONTIN_0 (kernel_read_sexp, sc);
5082 return K_INERT;
5083 }
5084 else
5085 {
5086 CONTIN_1 (dcrry_2A01VLL, kernel_read_list, sc, accum);
5087 CONTIN_0 (kernel_read_sexp, sc);
5088 return K_INERT;
5089 }
5090 }
5091
5092 /*_ . Treat end of dotted list */
5093 static
5094 DEF_CFUNC (ps0a2, kernel_treat_dotted_list, REF_DESTR(kernel_read_list),T_NO_K)
5095 {
5096 WITH_2_ARGS(args,value);
5097
5098 if (token (sc) != TOK_RPAREN)
5099 {
5100 KERNEL_ERROR_0 (sc, "syntax error: illegal dot expression");
5101 }
5102 else
5103 {
5104 change_nesting_depth(sc, -1);
5105 return (unsafe_v2reverse_in_place (value, args));
5106 }
5107 }
5108
5109 /*_ . Treat quasiquoted vector */
5110 static
5111 DEF_CFUNC (ps0a1, kernel_treat_qquoted_vec, K_ANY,T_NO_K)
5112 {
5113 pko value = arg1;
5114 /* $$IMPROVE ME Include vector applicative directly, not by applying
5115 symbol. This does need to apply, though, so that backquote (now
5116 seeing a list) can be run on "value" first*/
5117 return (mcons (mk_symbol ("apply"),
5118 mcons (mk_symbol ("vector"),
5119 mcons (mcons (sc->QQUOTE, mcons (value, K_NIL)),
5120 K_NIL))));
5121 }
5122 /*_ , Loading files */
5123 /*_ . load_from_port */
5124 /* $$RETHINK ME This soon need no longer be a cfunc */
5125 SIG_CHKARRAY(load_from_port) = { REF_OPER(is_inport), REF_OPER(is_environment)};
5126 DEF_SIMPLE_CFUNC(ps0a2,load_from_port,0)
5127 {
5128 WITH_2_ARGS(inport,env);
5129 assert (is_port(inport));
5130 assert (is_environment(env));
5131 /* Print that we're loading (If there's an outport, and we may want
5132 to add a verbosity condition based on a dynamic variable) */
5133 pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5134 if(the_outport && (the_outport != K_NIL))
5135 {
5136 port * pt = portvalue(inport);
5137 if(pt->kind & port_file)
5138 {
5139 const char *fname = pt->rep.stdio.filename;
5140 if (!fname)
5141 { fname = "<unknown>"; }
5142 putstr(sc,"Loading ");
5143 putstr(sc,fname);
5144 putstr(sc,"\n");
5145 }
5146 }
5147
5148 /* We will do the evals in ENV */
5149 sc->envir = env;
5150 klink_push_dyn_binding(sc,K_INPORT,inport);
5151 return kernel_rel(sc);
5152 }
5153 /*_ . load */
5154 /* $$OBSOLETE */
5155 SIG_CHKARRAY(k_load_file) = { REF_OPER(is_string), };
5156 DEF_SIMPLE_APPLICATIVE(ps0a1,k_load_file,0,ground, "load")
5157 {
5158 WITH_1_ARGS(filename_ob);
5159 const char * filename = string_value(filename_ob);
5160 pko p = port_from_filename (filename, port_file | port_input);
5161 if (p == K_NIL)
5162 {
5163 KERNEL_ERROR_1(sc,"unable to open", filename_ob);
5164 }
5165
5166 return load_from_port(sc,p,sc->envir);
5167 }
5168 /*_ . get-module-from-port */
5169 SIG_CHKARRAY(k_get_mod_fm_port) =
5170 { REF_OPER(is_port), REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
5171 DEF_SIMPLE_APPLICATIVE(ps0a2,k_get_mod_fm_port,0,ground, "get-module-from-port")
5172 {
5173 WITH_2_ARGS(port, params);
5174 pko env = mk_std_environment();
5175 if(params != K_INERT)
5176 {
5177 assert(is_environment(params));
5178 kernel_define (env, mk_symbol ("module-parameters"), params);
5179 }
5180 /* Ultimately return that environment. */
5181 CONTIN_1R(dcrry_NdotALL,val2val,sc,env);
5182 return load_from_port(sc, port,env);
5183 }
5184
5185 /*_ . Printing */
5186 /*_ , Writing chars */
5187 INTERFACE void
5188 putstr (klink * sc, const char *s)
5189 {
5190 pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5191 port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5192
5193 if (pt->kind & port_file)
5194 {
5195 fputs (s, pt->rep.stdio.file);
5196 }
5197 else
5198 {
5199 for (; *s; s++)
5200 {
5201 if (pt->rep.string.curr != pt->rep.string.past_the_end)
5202 {
5203 *pt->rep.string.curr++ = *s;
5204 }
5205 else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5206 {
5207 *pt->rep.string.curr++ = *s;
5208 }
5209 }
5210 }
5211 }
5212
5213 static void
5214 putchars (klink * sc, const char *s, int len)
5215 {
5216 pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5217 port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5218
5219 if (pt->kind & port_file)
5220 {
5221 fwrite (s, 1, len, pt->rep.stdio.file);
5222 }
5223 else
5224 {
5225 for (; len; len--)
5226 {
5227 if (pt->rep.string.curr != pt->rep.string.past_the_end)
5228 {
5229 *pt->rep.string.curr++ = *s++;
5230 }
5231 else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5232 {
5233 *pt->rep.string.curr++ = *s++;
5234 }
5235 }
5236 }
5237 }
5238
5239 INTERFACE void
5240 putcharacter (klink * sc, int c)
5241 {
5242 pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5243 port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5244
5245 if (pt->kind & port_file)
5246 {
5247 fputc (c, pt->rep.stdio.file);
5248 }
5249 else
5250 {
5251 if (pt->rep.string.curr != pt->rep.string.past_the_end)
5252 {
5253 *pt->rep.string.curr++ = c;
5254 }
5255 else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5256 {
5257 *pt->rep.string.curr++ = c;
5258 }
5259 }
5260 }
5261
5262 #define ok_abbrev(x) (is_pair(x) && cdr(x) == K_NIL)
5263
5264 static void
5265 printslashstring (klink * sc, char *p, int len)
5266 {
5267 int i;
5268 unsigned char *s = (unsigned char *) p;
5269 putcharacter (sc, '"');
5270 for (i = 0; i < len; i++)
5271 {
5272 if (*s == 0xff || *s == '"' || *s < ' ' || *s == '\\')
5273 {
5274 putcharacter (sc, '\\');
5275 switch (*s)
5276 {
5277 case '"':
5278 putcharacter (sc, '"');
5279 break;
5280 case '\n':
5281 putcharacter (sc, 'n');
5282 break;
5283 case '\t':
5284 putcharacter (sc, 't');
5285 break;
5286 case '\r':
5287 putcharacter (sc, 'r');
5288 break;
5289 case '\\':
5290 putcharacter (sc, '\\');
5291 break;
5292 default:
5293 {
5294 int d = *s / 16;
5295 putcharacter (sc, 'x');
5296 if (d < 10)
5297 {
5298 putcharacter (sc, d + '0');
5299 }
5300 else
5301 {
5302 putcharacter (sc, d - 10 + 'A');
5303 }
5304 d = *s % 16;
5305 if (d < 10)
5306 {
5307 putcharacter (sc, d + '0');
5308 }
5309 else
5310 {
5311 putcharacter (sc, d - 10 + 'A');
5312 }
5313 }
5314 }
5315 }
5316 else
5317 {
5318 putcharacter (sc, *s);
5319 }
5320 s++;
5321 }
5322 putcharacter (sc, '"');
5323 }
5324
5325 /*_ , Printing atoms */
5326 static void
5327 printatom (klink * sc, pko l)
5328 {
5329 char *p;
5330 int len;
5331 atom2str (sc, l, &p, &len);
5332 putchars (sc, p, len);
5333 }
5334
5335
5336 /* Uses internal buffer unless string pointer is already available */
5337 static void
5338 atom2str (klink * sc, pko l, char **pp, int *plen)
5339 {
5340 WITH_REPORTER(sc);
5341 char *p;
5342 pko p_escapes = klink_find_dyn_binding(sc,K_PRINT_FLAG);
5343 int escapes = (p_escapes == K_T) ? 1 : 0;
5344
5345 if (l == K_NIL)
5346 {
5347 p = "()";
5348 }
5349 else if (l == K_T)
5350 {
5351 p = "#t";
5352 }
5353 else if (l == K_F)
5354 {
5355 p = "#f";
5356 }
5357 else if (l == K_INERT)
5358 {
5359 p = "#inert";
5360 }
5361 else if (l == K_IGNORE)
5362 {
5363 p = "#ignore";
5364 }
5365 else if (l == K_EOF)
5366 {
5367 p = "#<EOF>";
5368 }
5369 else if (is_port (l))
5370 {
5371 p = sc->strbuff;
5372 snprintf (p, STRBUFFSIZE, "#<PORT>");
5373 }
5374 else if (is_number (l))
5375 {
5376 p = sc->strbuff;
5377 if (num_is_integer (l))
5378 {
5379 snprintf (p, STRBUFFSIZE, "%ld", ivalue (l));
5380 }
5381 else
5382 {
5383 snprintf (p, STRBUFFSIZE, "%.10g", rvalue (l));
5384 }
5385 }
5386 else if (is_string (l))
5387 {
5388 if (!escapes)
5389 {
5390 p = string_value (l);
5391 }
5392 else
5393 { /* Hack, uses the fact that printing is needed */
5394 *pp = sc->strbuff;
5395 *plen = 0;
5396 printslashstring (sc, string_value (l), string_len (l));
5397 return;
5398 }
5399 }
5400 else if (is_character (l))
5401 {
5402 int c = charvalue (l);
5403 p = sc->strbuff;
5404 if (!escapes)
5405 {
5406 p[0] = c;
5407 p[1] = 0;
5408 }
5409 else
5410 {
5411 switch (c)
5412 {
5413 case ' ':
5414 snprintf (p, STRBUFFSIZE, "#\\space");
5415 break;
5416 case '\n':
5417 snprintf (p, STRBUFFSIZE, "#\\newline");
5418 break;
5419 case '\r':
5420 snprintf (p, STRBUFFSIZE, "#\\return");
5421 break;
5422 case '\t':
5423 snprintf (p, STRBUFFSIZE, "#\\tab");
5424 break;
5425 default:
5426 #if USE_ASCII_NAMES
5427 if (c == 127)
5428 {
5429 snprintf (p, STRBUFFSIZE, "#\\del");
5430 break;
5431 }
5432 else if (c < 32)
5433 {
5434 snprintf (p, STRBUFFSIZE, "#\\%s", charnames[c]);
5435 break;
5436 }
5437 #else
5438 if (c < 32)
5439 {
5440 snprintf (p, STRBUFFSIZE, "#\\x%x", c);
5441 break;
5442 break;
5443 }
5444 #endif
5445 snprintf (p, STRBUFFSIZE, "#\\%c", c);
5446 break;
5447 break;
5448 }
5449 }
5450 }
5451 else if (is_symbol (l))
5452 {
5453 p = symname (sc,l);
5454 }
5455
5456
5457 else if (is_environment (l))
5458 {
5459 p = "#<ENVIRONMENT>";
5460 }
5461 else if (is_continuation (l))
5462 {
5463 p = "#<CONTINUATION>";
5464 }
5465 else if (is_operative (l)
5466 /* $$TRANSITIONAL When these can be launched by
5467 themselves, this check will be folded into is_operative */
5468 || is_type (l, T_DESTRUCTURE)
5469 || is_type (l, T_TYPECHECK)
5470 || is_type (l, T_TYPEP))
5471 {
5472 /* $$TRANSITIONAL This logic will move, probably into
5473 k_print_special_and_balk_p, and become more general. */
5474 pko slot =
5475 print_lookup_unwraps ?
5476 reverse_find_slot_in_env_aux(print_lookup_unwraps,l) :
5477 0;
5478 if(slot)
5479 {
5480 p = sc->strbuff;
5481 snprintf (p, STRBUFFSIZE, ",(unwrap #,%s)", symname(0, car(slot)));
5482 }
5483 else
5484 {
5485 pko slot =
5486 print_lookup_to_xary ?
5487 reverse_find_slot_in_env_aux(print_lookup_to_xary,l) :
5488 0;
5489 if(slot)
5490 {
5491 /* We don't say it's the tree-ary version, because the
5492 tree-ary conversion is not exposed. */
5493 p = symname(0, car(slot));
5494 }
5495 else
5496 {
5497 pko slot =
5498 all_builtins_env ?
5499 reverse_find_slot_in_env_aux(all_builtins_env, l) :
5500 0;
5501 if(slot)
5502 {
5503 p = symname(0, car(slot));
5504 }
5505 else
5506 { p = "#<OPERATIVE>"; }}
5507 }
5508 }
5509 else if (is_promise (l))
5510 {
5511 p = "#<PROMISE>";
5512 }
5513 else if (is_applicative (l))
5514 {
5515 p = "#<APPLICATIVE>";
5516 }
5517 else if (is_type (l, T_ENCAP))
5518 {
5519 p = "#<ENCAPSULATION>";
5520 }
5521 else if (is_type (l, T_KEY))
5522 {
5523 p = "#<KEY>";
5524 }
5525 else if (is_type (l, T_RECUR_TRACKER))
5526 {
5527 p = "#<RECURRENCE TRACKER>";
5528 }
5529 else if (is_type (l, T_RECURRENCES))
5530 {
5531 p = "#<RECURRENCE TABLE>";
5532 }
5533 else
5534 {
5535 p = sc->strbuff;
5536 snprintf (p, STRBUFFSIZE, "#<ERROR %d>", _get_type(l));
5537 }
5538 *pp = p;
5539 *plen = strlen (p);
5540 }
5541
5542 /*_ , C-style entry points */
5543 /*_ . Print sexp */
5544 /*_ , kernel_print_sexp */
5545 SIG_CHKARRAY(kernel_print_sexp) =
5546 { K_ANY, REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
5547 static
5548 DEF_SIMPLE_CFUNC (ps0a2, kernel_print_sexp,0)
5549 {
5550 WITH_2_ARGS(sexp, lookup_env);
5551 pko recurrences = get_recurrences(sc, sexp);
5552 pko tracker = recurrences_to_recur_tracker(recurrences);
5553 /* $$IMPROVE ME Default to an environment that knows sharp
5554 constants */
5555 return kernel_print_sexp_aux
5556 (sc, sexp,
5557 tracker,
5558 ((lookup_env == K_INERT) ? ground_env : lookup_env));
5559 }
5560 /*_ , k_print_special_and_balk_p */
5561 /* Possibly print a replacement or prefix. Return 1 if we should now
5562 skip printing sexp (Because it's shared), 0 otherwise. */
5563 static int
5564 k_print_special_and_balk_p
5565 (klink * sc, pko tracker, pko lookup_env, pko sexp)
5566 {
5567 WITH_REPORTER(0);
5568 /* If this object is directly known to printer, print its symbol. */
5569 if(lookup_env != K_NIL)
5570 {
5571 pko slot = reverse_find_slot_in_env_aux(lookup_env,sexp);
5572 if(slot)
5573 {
5574 putstr (sc, "#,"); /* Reader is to convert the symbol */
5575 printatom (sc, car(slot));
5576 return 1;
5577 }
5578 }
5579 if(tracker == K_NIL)
5580 { return 0; }
5581
5582 /* $$IMPROVE ME Parameterize this and share that parameterization
5583 with get_recurrences */
5584 switch(_get_type(sexp))
5585 {
5586 case T_SYMBOL:
5587 case T_NUMBER:
5588 return 0;
5589 default:
5590 break;
5591 }
5592
5593 WITH_PSYC_UNBOXED(kt_recur_tracker,tracker, T_RECUR_TRACKER, sc);
5594 int index = objtable_get_index(pdata->objs,pdata->table_size,sexp);
5595 if(index < 0) { return 0; }
5596 recur_entry * slot = &pdata->entries[index];
5597 if(slot->count <= 1) { return 0; }
5598
5599 if(slot->seen_in_walk)
5600 {
5601 char *p = sc->strbuff;
5602 snprintf (p, STRBUFFSIZE, "#%d", slot->index_in_walk);
5603 putchars (sc, p, strlen (p));
5604 return 1; /* Skip printing the object */
5605 }
5606 else
5607 {
5608 slot->seen_in_walk = 1;
5609 slot->index_in_walk = pdata->current_index;
5610 pdata->current_index++;
5611 char *p = sc->strbuff;
5612 snprintf (p, STRBUFFSIZE, "#%d=", slot->index_in_walk);
5613 putchars (sc, p, strlen (p));
5614 return 0; /* Still should print the object */
5615 }
5616 }
5617 /*_ , kernel_print_sexp_aux */
5618 SIG_CHKARRAY(kernel_print_sexp_aux) =
5619 { K_ANY, REF_OPER(is_recur_tracker), REF_OPER(is_environment), };
5620 static
5621 DEF_SIMPLE_CFUNC (ps0a3, kernel_print_sexp_aux,0)
5622 {
5623 WITH_3_ARGS(sexp, recur_tracker, lookup_env);
5624 WITH_REPORTER(0);
5625 if(k_print_special_and_balk_p(sc, recur_tracker, lookup_env, sexp))
5626 { return K_INERT; }
5627 if (is_vector (sexp))
5628 {
5629 putstr (sc, "#(");
5630 CONTIN_4 (dcrry_4dotALL, kernel_print_vec_from, sc, sexp,
5631 mk_integer (0), recur_tracker, lookup_env);
5632 return K_INERT;
5633 }
5634 else if (!is_pair (sexp))
5635 {
5636 printatom (sc, sexp);
5637 return K_INERT;
5638 }
5639 /* $$FIX ME Recognize quote etc.
5640
5641 That is hard since the quote operative is not currently defined
5642 as such and we no longer have syntax.
5643 */
5644 else if (car (sexp) == sc->QUOTE && ok_abbrev (cdr (sexp)))
5645 {
5646 putstr (sc, "'");
5647 return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
5648 }
5649 else if (car (sexp) == sc->QQUOTE && ok_abbrev (cdr (sexp)))
5650 {
5651 putstr (sc, "`");
5652 return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
5653 }
5654 else if (car (sexp) == sc->UNQUOTE && ok_abbrev (cdr (sexp)))
5655 {
5656 putstr (sc, ",");
5657 return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
5658 }
5659 else if (car (sexp) == sc->UNQUOTESP && ok_abbrev (cdr (sexp)))
5660 {
5661 putstr (sc, ",@");
5662 return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
5663 }
5664 else
5665 {
5666 putstr (sc, "(");
5667 CONTIN_0_RAW(REF_OBJ(k_print_terminate_list), sc);
5668 CONTIN_3 (dcrry_2dotALL, kernel_print_list, sc, cdr (sexp), recur_tracker, lookup_env);
5669 return kernel_print_sexp_aux (sc, car (sexp), recur_tracker, lookup_env);
5670 }
5671 }
5672 /*_ , print_value */
5673 DEF_BOXED_CURRIED(print_value,
5674 dcrry_1VLL,
5675 REF_KEY(K_NIL),
5676 REF_OPER (kernel_print_sexp));
5677 /*_ . k_print_string */
5678 SIG_CHKARRAY(k_print_string) = { REF_OPER(is_string), };
5679 static
5680 DEF_SIMPLE_CFUNC (ps0a1, k_print_string,T_NO_K)
5681 {
5682 WITH_1_ARGS(str);
5683 putstr (sc, string_value(str));
5684 return K_INERT;
5685 }
5686 /*_ . k_print_terminate_list */
5687 /* $$RETHINK ME This may be the long way to do it. */
5688 static
5689 BOX_OF(kt_string) _k_string_rpar =
5690 { T_STRING | T_IMMUTABLE,
5691 { ")", sizeof(")"), },
5692 };
5693 static
5694 BOX_OF(kt_vec2) _k_list_string_rpar =
5695 { T_PAIR | T_IMMUTABLE,
5696 { REF_OBJ(_k_string_rpar), REF_KEY(K_NIL)}
5697 };
5698 static
5699 DEF_BOXED_CURRIED(k_print_terminate_list,
5700 dcrry_1dotALL,
5701 REF_OBJ(_k_list_string_rpar),
5702 REF_OPER(k_print_string));
5703 /*_ . k_newline */
5704 RGSTR(ground, "newline", REF_OBJ(k_newline))
5705 static
5706 BOX_OF(kt_string) _k_string_newline =
5707 { T_STRING | T_IMMUTABLE,
5708 { "\n", sizeof("\n"), }, };
5709 static
5710 BOX_OF(kt_vec2) _k_list_string_newline =
5711 { T_PAIR | T_IMMUTABLE,
5712 { REF_OBJ(_k_string_newline), REF_KEY(K_NIL)}
5713 };
5714 static
5715 DEF_BOXED_CURRIED(k_newline,
5716 dcrry_1dotALL,
5717 REF_OBJ(_k_list_string_newline),
5718 REF_OPER(k_print_string));
5719
5720 /*_ . kernel_print_list */
5721 static
5722 DEF_CFUNC (ps0a3, kernel_print_list, REF_DESTR(kernel_print_sexp_aux),0)
5723 {
5724 WITH_REPORTER(0);
5725 WITH_3_ARGS(sexp, recur_tracker, lookup_env);
5726 if(is_pair (sexp)) { putstr (sc, " "); }
5727 else if (sexp != K_NIL) { putstr (sc, " . "); }
5728 else { }
5729
5730 if(k_print_special_and_balk_p(sc, recur_tracker, lookup_env, sexp))
5731 { return K_INERT; }
5732 if (is_pair (sexp))
5733 {
5734 CONTIN_3 (dcrry_3dotALL, kernel_print_list, sc, cdr (sexp), recur_tracker, lookup_env);
5735 return kernel_print_sexp_aux (sc, car (sexp), recur_tracker, lookup_env);
5736 }
5737 if (is_vector (sexp))
5738 {
5739 /* $$RETHINK ME What does this even print? */
5740 CONTIN_3 (dcrry_3dotALL, kernel_print_list, sc, K_NIL, recur_tracker, lookup_env);
5741 return kernel_print_sexp_aux (sc, sexp, recur_tracker, lookup_env);
5742 }
5743
5744 if (sexp != K_NIL)
5745 {
5746 printatom (sc, sexp);
5747 }
5748 return K_INERT;
5749 }
5750
5751
5752 /*_ . kernel_print_vec_from */
5753 SIG_CHKARRAY(kernel_print_vec_from) =
5754 { K_ANY,
5755 REF_OPER(is_integer),
5756 REF_OPER(is_recur_tracker),
5757 REF_OPER(is_environment), };
5758 DEF_SIMPLE_CFUNC (ps0a4, kernel_print_vec_from,0)
5759 {
5760 WITH_4_ARGS(vec,k_i, recur_tracker, lookup_env);
5761 int i = ivalue (k_i);
5762 int len = vector_len (vec);
5763 if (i == len)
5764 {
5765 putstr (sc, ")");
5766 return K_INERT;
5767 }
5768 else
5769 {
5770 pko elem = vector_elem (vec, i);
5771 set_ivalue (k_i, i + 1);
5772 CONTIN_4 (dcrry_4dotALL, kernel_print_vec_from, sc, vec, arg2, recur_tracker, lookup_env);
5773 putstr (sc, " ");
5774 return kernel_print_sexp_aux (sc, elem, recur_tracker, lookup_env);
5775 }
5776 }
5777 /*_ , Kernel entry points */
5778 /*_ . write */
5779 DEF_APPLICATIVE_W_DESTR(ps0a1,k_write,K_ANY_SINGLETON,0,ground, "write")
5780 {
5781 WITH_1_ARGS(p);
5782 klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
5783 return kernel_print_sexp(sc,p,K_INERT);
5784 }
5785
5786 /*_ . display */
5787 DEF_APPLICATIVE_W_DESTR(ps0a1,k_display,K_ANY_SINGLETON,0,ground, "display")
5788 {
5789 WITH_1_ARGS(p);
5790 klink_push_dyn_binding(sc,K_PRINT_FLAG,K_F);
5791 return kernel_print_sexp(sc,p,K_INERT);
5792 }
5793
5794 /*_ , Tracing */
5795 /*_ . tracing_say */
5796 /* $$TRANSITIONAL Until we have actual trace hook */
5797 SIG_CHKARRAY(tracing_say) = { REF_OPER(is_string), K_ANY, };
5798 DEF_SIMPLE_CFUNC (ps0a2, tracing_say,T_NO_K)
5799 {
5800 WITH_2_ARGS(k_string, value);
5801 if (sc->tracing)
5802 {
5803 putstr (sc, string_value(k_string));
5804 }
5805 return value;
5806 }
5807
5808
5809 /*_ . Equivalence */
5810 /*_ , Equivalence of atoms */
5811 SIG_CHKARRAY(eqv) = { K_ANY, K_ANY, };
5812 DEF_SIMPLE_APPLICATIVE(b00a2,eqv,T_NO_K,simple,"equal?/2-atom-atom")
5813 {
5814 WITH_2_ARGS(a,b);
5815
5816 if (is_string (a))
5817 {
5818 if (is_string (b))
5819 {
5820 const char * a_str = string_value (a);
5821 const char * b_str = string_value (b);
5822 if (a_str == b_str) { return 1; }
5823 return !strcmp(a_str, b_str);
5824 }
5825 else
5826 { return (0); }
5827 }
5828 else if (is_number (a))
5829 {
5830 if (is_number (b))
5831 {
5832 if (num_is_integer (a) == num_is_integer (b))
5833 return num_eq (nvalue (a), nvalue (b));
5834 }
5835 return (0);
5836 }
5837 else if (is_character (a))
5838 {
5839 if (is_character (b))
5840 return charvalue (a) == charvalue (b);
5841 else
5842 return (0);
5843 }
5844 else if (is_port (a))
5845 {
5846 if (is_port (b))
5847 return a == b;
5848 else
5849 return (0);
5850 }
5851 else
5852 {
5853 return (a == b);
5854 }
5855 }
5856 /*_ , Equivalence of containers */
5857
5858 /*_ . Hash function */
5859 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
5860
5861 static int
5862 hash_fn (const char *key, int table_size)
5863 {
5864 unsigned int hashed = 0;
5865 const char *c;
5866 int bits_per_int = sizeof (unsigned int) * 8;
5867
5868 for (c = key; *c; c++)
5869 {
5870 /* letters have about 5 bits in them */
5871 hashed = (hashed << 5) | (hashed >> (bits_per_int - 5));
5872 hashed ^= *c;
5873 }
5874 return hashed % table_size;
5875 }
5876 #endif
5877
5878 /* Quick and dirty hash function for pointers */
5879 static int
5880 ptr_hash_fn(void * ptr, int table_size)
5881 { return (long)ptr % table_size; }
5882
5883 /*_ . binder/accessor maker */
5884 pko make_keyed_variable(pko gen_binder, pko gen_accessor)
5885 {
5886 /* Make a unique key object */
5887 pko key = mk_void();
5888 pko binder = wrap (mk_curried
5889 (dcrry_3A01dotVLL,
5890 LIST1(key),
5891 gen_binder));
5892 pko accessor = wrap (mk_curried
5893 (dcrry_1A01,
5894 LIST1(key),
5895 gen_accessor));
5896 /* Curry and wrap the two things. */
5897 return LIST2 (binder, accessor);
5898 }
5899
5900 /*_ . Environment implementation */
5901 /*_ , New-style environment objects */
5902
5903 /*_ . Types */
5904
5905 /* T_ENV_FRAME is a vec2 used as a pair in the env tree. It
5906 indicates a frame boundary.
5907 */
5908 /* T_ENV_PAIR is another vec2 used as a pair in the env tree. It
5909 indicates no frame boundary.
5910 */
5911
5912 /* Other types are (hackishly) still shared with the vanilla types:
5913
5914 A vector is interpeted as a hash table vector that is "as if" it
5915 were a list of T_ENV_PAIR. Each element is an alist of bindings.
5916 It can only hold symbol bindings, not keyed bindings, because we
5917 can't hash keyed bindings.
5918
5919 A pair is interpreted as a binding of something and value. That
5920 something can be either a symbol or a key (void object). It is
5921 held directly by an T_ENV_FRAME or T_ENV_PAIR (or "as if", by the
5922 alists of a hash table vector).
5923
5924 */
5925
5926 /*_ . Object functions */
5927
5928 DEF_T_PRED (is_environment, T_ENV_FRAME,ground,"environment?/o1");
5929
5930 /*_ , New environment implementation */
5931
5932 #ifndef USE_ALIST_ENV
5933 static pko
5934 find_slot_in_env_vector (pko eobj, pko hdl)
5935 {
5936 for (; eobj != K_NIL; eobj = unsafe_v2cdr (eobj))
5937 {
5938 assert (is_pair (eobj));
5939 pko slot = unsafe_v2car (eobj);
5940 assert (is_pair (slot));
5941 if (unsafe_v2car (slot) == hdl)
5942 {
5943 return slot;
5944 }
5945 }
5946 return 0;
5947 }
5948
5949 static pko
5950 reverse_find_slot_in_env_vector (pko eobj, pko value)
5951 {
5952 for (; eobj != K_NIL; eobj = unsafe_v2cdr (eobj))
5953 {
5954 assert (is_pair (eobj));
5955 pko slot = unsafe_v2car (eobj);
5956 assert (is_pair (slot));
5957 if (unsafe_v2cdr (slot) == value)
5958 {
5959 return slot;
5960 }
5961 }
5962 return 0;
5963 }
5964 #endif
5965
5966 /*
5967 * If we're using vectors, each frame of the environment may be a hash
5968 * table: a vector of alists hashed by variable name. In practice, we
5969 * use a vector only for the initial frame; subsequent frames are too
5970 * small and transient for the lookup speed to out-weigh the cost of
5971 * making a new vector.
5972 */
5973 static INLINE pko
5974 make_new_frame(pko old_env)
5975 {
5976 pko new_frame;
5977 #ifndef USE_ALIST_ENV
5978 /* $$IMPROVE ME Make a better test for whether to make vector. */
5979 /* The interaction-environment has about 300 variables in it. */
5980 if (old_env == K_NIL)
5981 {
5982 new_frame = mk_vector (461, K_NIL);
5983 }
5984 else
5985 #endif
5986 {
5987 new_frame = K_NIL;
5988 }
5989
5990 return v2cons (T_ENV_FRAME, new_frame, old_env);
5991 }
5992
5993 static INLINE void
5994 new_slot_spec_in_env (pko env, pko variable, pko value)
5995 {
5996 assert(is_environment(env));
5997 assert(is_symbol(variable));
5998 pko slot = mcons (variable, value);
5999 pko car_env = unsafe_v2car (env);
6000 #ifndef USE_ALIST_ENV
6001 if (is_vector (car_env))
6002 {
6003 int location = hash_fn (symname (0,variable), vector_len (car_env));
6004
6005 set_vector_elem (car_env, location,
6006 cons (slot,
6007 vector_elem (car_env, location)));
6008 }
6009 else
6010 #endif
6011 {
6012 pko new_list = v2cons (T_ENV_PAIR, slot, car_env);
6013 unsafe_v2set_car (env, new_list);
6014 }
6015 }
6016
6017 enum env_frame_search_restriction
6018 {
6019 env_fsr_all,
6020 env_fsr_only_coming_frame,
6021 env_fsr_only_this_frame,
6022 };
6023
6024 /* This explores a tree of bindings, punctuated by frames past which
6025 we sometimes don't search. */
6026 static pko
6027 find_slot_in_env_aux (pko eobj, pko hdl, int restr)
6028 {
6029 if(eobj == K_NIL)
6030 { return 0; }
6031 _kt_tag type = _get_type (eobj);
6032 switch(type)
6033 {
6034 /* We have a slot (Which for now is just a pair) */
6035 case T_PAIR:
6036 if(unsafe_v2car (eobj) == hdl)
6037 { return eobj; }
6038 else
6039 { return 0; }
6040 #ifndef USE_ALIST_ENV
6041 case T_VECTOR:
6042 {
6043 /* Only for symbols. */
6044 if(!is_symbol (hdl)) { return 0; }
6045 int location = hash_fn (symname (0,hdl), vector_len (eobj));
6046 pko el = vector_elem (eobj, location);
6047 return find_slot_in_env_vector (el, hdl);
6048 }
6049 #endif
6050 /* We have some sort of env pair */
6051 case T_ENV_FRAME:
6052 /* Check whether we should keep looking. */
6053 switch(restr)
6054 {
6055 case env_fsr_all:
6056 break;
6057 case env_fsr_only_coming_frame:
6058 restr = env_fsr_only_this_frame;
6059 break;
6060 case env_fsr_only_this_frame:
6061 return 0;
6062 default:
6063 errx (3,
6064 "find_slot_in_env_aux: Bad restriction enum: %d", restr);
6065 }
6066 /* Fallthru */
6067 case T_ENV_PAIR:
6068 {
6069 /* Explore car before cdr */
6070 pko found = find_slot_in_env_aux (unsafe_v2car (eobj), hdl, restr);
6071 if(found) { return found; }
6072 return find_slot_in_env_aux (unsafe_v2cdr (eobj),hdl,restr);
6073 }
6074 default:
6075 /* No other type should be found */
6076 errx (3,
6077 "find_slot_in_env_aux: Bad type: %d", type);
6078 return 0; /* NOTREACHED */
6079 }
6080 }
6081
6082 static pko
6083 find_slot_in_env (pko env, pko hdl, int all)
6084 {
6085 assert(is_environment(env));
6086 enum env_frame_search_restriction restr =
6087 all ? env_fsr_all : env_fsr_only_coming_frame;
6088 return find_slot_in_env_aux(env,hdl,restr);
6089 }
6090 /*_ , Reverse find-slot */
6091 /*_ . env_confirm_slot */
6092 static int
6093 env_confirm_slot(pko env, pko slot)
6094 {
6095 assert(is_pair(slot));
6096 return
6097 (find_slot_in_env_aux(env,unsafe_v2car(slot),env_fsr_all) == slot);
6098 }
6099 /*_ . reverse_find_slot_in_env_aux2 */
6100 static pko
6101 reverse_find_slot_in_env_aux2(pko env, pko eobj, pko value)
6102 {
6103 if(eobj == K_NIL)
6104 { return 0; }
6105 _kt_tag type = _get_type (eobj);
6106 switch(type)
6107 {
6108 /* We have a slot (Which for now is just a pair) */
6109 case T_PAIR:
6110 if((unsafe_v2cdr (eobj) == value)
6111 && env_confirm_slot(env, eobj))
6112 { return eobj; }
6113 else
6114 { return 0; }
6115 #ifndef USE_ALIST_ENV
6116 case T_VECTOR:
6117 {
6118 /* $$IMPROVE ME Create a reverse-lookup vector if we come here
6119 and there is none. */
6120 int i;
6121 for(i = 0; i < vector_len (eobj); ++i)
6122 {
6123 pko slot = reverse_find_slot_in_env_vector(vector_elem (eobj, i), value);
6124 if(slot &&
6125 env_confirm_slot(env, slot))
6126 { return slot; }
6127 }
6128 return 0;
6129 }
6130 #endif
6131 /* We have some sort of env pair */
6132 case T_ENV_FRAME:
6133 /* Fallthru */
6134 case T_ENV_PAIR:
6135 {
6136 /* Explore car before cdr */
6137 pko found =
6138 reverse_find_slot_in_env_aux2 (env, unsafe_v2car (eobj), value);
6139 if(found && env_confirm_slot(env, found))
6140 { return found; }
6141 found =
6142 reverse_find_slot_in_env_aux2 (env, unsafe_v2cdr (eobj), value);
6143 if(found && env_confirm_slot(env, found))
6144 { return found; }
6145 return 0;
6146 }
6147 default:
6148 /* No other type should be found */
6149 errx (3,
6150 "reverse_find_slot_in_env_aux2: Bad type: %d", type);
6151 return 0; /* NOTREACHED */
6152 }
6153 }
6154
6155 /*_ . reverse_find_slot_in_env_aux */
6156 static pko
6157 reverse_find_slot_in_env_aux (pko env, pko value)
6158 {
6159 assert(is_environment(env));
6160 return reverse_find_slot_in_env_aux2(env, env, value);
6161 }
6162
6163 /*_ . Entry point */
6164 /* Exposed for testing */
6165 /* NB, args are in different order than in the helpers */
6166 SIG_CHKARRAY(reverse_find_slot_in_env) =
6167 { K_ANY, REF_OPER(is_environment), };
6168 DEF_SIMPLE_APPLICATIVE (ps0a2, reverse_find_slot_in_env,T_NO_K,unsafe, "reverse-lookup")
6169 {
6170 WITH_2_ARGS(value,env);
6171 WITH_REPORTER(0);
6172 pko slot = reverse_find_slot_in_env_aux(env, value);
6173 if(slot) { return car(slot); }
6174 else
6175 {
6176 KERNEL_ERROR_0(sc, "reverse_find_slot_in_env: No match");
6177 }
6178 }
6179
6180 /*_ . reverse-binds?/2 */
6181 /* $$IMPROVE ME Maybe combine these */
6182 DEF_APPLICATIVE_W_DESTR(b00a2,reverse_binds_p,
6183 REF_DESTR(reverse_find_slot_in_env),
6184 T_NO_K,simple,"reverse-binds?/2")
6185 {
6186 WITH_2_ARGS(value,env);
6187 return reverse_find_slot_in_env_aux(env, value) ? 1 : 0;
6188 }
6189 /*_ , Shared functions */
6190
6191 static INLINE void
6192 new_frame_in_env (klink * sc, pko old_env)
6193 {
6194 sc->envir = make_new_frame (old_env);
6195 }
6196
6197 static INLINE void
6198 set_slot_in_env (pko slot, pko value)
6199 {
6200 assert (is_pair (slot));
6201 set_cdr (0, slot, value);
6202 }
6203
6204 static INLINE pko
6205 slot_value_in_env (pko slot)
6206 {
6207 WITH_REPORTER(0);
6208 assert (is_pair (slot));
6209 return cdr (slot);
6210 }
6211
6212 /*_ , Keyed static bindings */
6213 /*_ . Support */
6214 /*_ , Making them */
6215 /* Make a new frame containing just the one keyed static variable. */
6216 static INLINE pko
6217 env_plus_keyed_var (pko key, pko value, pko old_env)
6218 {
6219 pko slot = cons (key, value);
6220 return v2cons (T_ENV_FRAME, slot, old_env);
6221 }
6222 /*_ , Finding them */
6223 /* find_slot_in_env works for this too. */
6224 /*_ . Interface */
6225 /*_ , Binder */
6226 SIG_CHKARRAY(klink_ksb_binder) =
6227 { REF_OPER(is_key), K_ANY, REF_OPER(is_environment), };
6228 DEF_SIMPLE_CFUNC(ps0a3,klink_ksb_binder,T_NO_K)
6229 {
6230 WITH_3_ARGS(key, value, env);
6231 /* Check that env is in fact a environment. */
6232 if(!is_environment(env))
6233 {
6234 KERNEL_ERROR_1(sc,
6235 "klink_ksb_binder: Arg 2 must be an environment: ",
6236 env);
6237 }
6238 /* Return a new environment with just that binding. */
6239 return env_plus_keyed_var(key, value, env);
6240 }
6241
6242 /*_ , Accessor */
6243 SIG_CHKARRAY(klink_ksb_accessor) =
6244 { REF_OPER(is_key), };
6245 DEF_SIMPLE_CFUNC(ps0a1,klink_ksb_accessor,T_NO_K)
6246 {
6247 WITH_1_ARGS(key);
6248 pko value = find_slot_in_env(sc->envir,key,1);
6249 if(!value)
6250 {
6251 KERNEL_ERROR_0(sc, "klink_ksb_accessor: No binding found");
6252 }
6253
6254 return slot_value_in_env (value);
6255 }
6256
6257 /*_ , make_keyed_static_variable */
6258 RGSTR(ground, "make-keyed-static-variable", REF_OPER(make_keyed_static_variable))
6259 DEF_CFUNC(p00a0, make_keyed_static_variable,K_NO_TYPE,T_NO_K)
6260 {
6261 return make_keyed_variable(
6262 REF_OPER(klink_ksb_binder),
6263 REF_OPER (klink_ksb_accessor));
6264 }
6265 /*_ , Building environments */
6266 /* Argobject is checked internally, so K_ANY */
6267 DEF_APPLICATIVE_W_DESTR(ps0a1,make_environment,K_ANY,T_NO_K,ground, "make-environment")
6268 {
6269 WITH_1_ARGS(parents);
6270 /* $$IMPROVE ME Factor this so we only call get_list_metrics_aux
6271 once on this object. */
6272 int4 metrics;
6273 get_list_metrics_aux(parents, metrics);
6274 pko typecheck = REF_OPER(is_environment);
6275 /* This will reject dotted lists */
6276 if(!typecheck_repeat(sc,parents,&typecheck,1,1))
6277 {
6278 KERNEL_ERROR_0 (sc, "make_environment: argobject must be a list of environments");
6279 }
6280
6281 /* Collect the parent environments. */
6282 int i;
6283 pko rv_par_list = K_NIL;
6284 for(i = 0; i < metrics[lm_num_pairs]; ++i, parents = pair_cdr(0, parents))
6285 {
6286 pko pare = pair_car(0, parents);
6287 rv_par_list = v2cons (T_ENV_PAIR, pare, rv_par_list);
6288 }
6289
6290 /* Reverse the list in place. */
6291 pko par_list;
6292
6293 par_list = unsafe_v2reverse_in_place(K_NIL, rv_par_list);
6294
6295 /* $$IMPROVE ME Check for redundant environments and skip them.
6296 Check only *previous* environments, because we still need to
6297 search correctly. When recurrences walks environments too, we
6298 can use that to find them. */
6299 /* $$IMPROVE ME Add to environment information to block rechecks. */
6300
6301 /* Return a new environment with all of those as parents. */
6302 return make_new_frame(par_list);
6303 }
6304 /*_ , bindsp_1 */
6305 RGSTR(simple,"$binds?/2", REF_OPER(bindsp_1))
6306 SIG_CHKARRAY(bindsp_1) =
6307 { REF_OPER(is_environment), REF_OPER(is_symbol), };
6308 DEF_SIMPLE_CFUNC(bs0a2,bindsp_1,T_NO_K)
6309 {
6310 WITH_2_ARGS(env, sym);
6311 return find_slot_in_env(env, sym, 1) ? 1 : 0;
6312 }
6313 /*_ , find-binding */
6314 DEF_APPLICATIVE_W_DESTR(ps0a2,find_binding,REF_DESTR(bindsp_1),T_NO_K,ground,"find-binding")
6315 {
6316 WITH_2_ARGS(env, sym);
6317 pko binding = find_slot_in_env(env, sym, 1);
6318 if(binding)
6319 {
6320 return cons(K_T,slot_value_in_env (binding));
6321 }
6322 else
6323 {
6324 return cons(K_F,K_INERT);
6325 }
6326 }
6327
6328 /*_ . Stack */
6329 /*_ , Enumerations */
6330 enum klink_stack_cell_types
6331 {
6332 ksct_invalid,
6333 ksct_frame,
6334 ksct_binding,
6335 ksct_entry_guards,
6336 ksct_exit_guards,
6337 ksct_profile,
6338 ksct_args,
6339 ksct_arg_barrier, /* Barrier to propagating pseudo-env. */
6340 };
6341 /*_ , Structs */
6342
6343 struct dump_stack_frame
6344 {
6345 pko envir;
6346 pko ff;
6347 };
6348 struct stack_binding
6349 {
6350 pko key;
6351 pko value;
6352 };
6353
6354 struct stack_guards
6355 {
6356 pko guards;
6357 pko envir;
6358 };
6359
6360 struct stack_profiling
6361 {
6362 pko ff;
6363 int initial_count;
6364 int returned_p;
6365 };
6366
6367 struct stack_arg
6368 {
6369 pko vec;
6370 int frame_depth;
6371 };
6372
6373 typedef struct dump_stack_frame_cell
6374 {
6375 enum klink_stack_cell_types type;
6376 _kt_spagstack next;
6377 union
6378 {
6379 struct dump_stack_frame frame;
6380 struct stack_binding binding;
6381 struct stack_guards guards;
6382 struct stack_profiling profiling;
6383 struct stack_arg pseudoenv;
6384 } data;
6385 } dump_stack_frame_cell;
6386
6387 /*_ , Initialize */
6388
6389 static INLINE void
6390 dump_stack_initialize (klink * sc)
6391 {
6392 sc->dump = 0;
6393 }
6394
6395 static INLINE int
6396 stack_empty (klink * sc)
6397 { return sc->dump == 0; }
6398
6399 /*_ , Frames */
6400 static int
6401 klink_pop_cont (klink * sc)
6402 {
6403 _kt_spagstack rv_pseudoenvs = 0;
6404
6405 /* Always return frame, which sc->dump will be set to. */
6406 /* for(frame = sc->dump; frame != 0; frame = frame->next) */
6407 while(1)
6408 {
6409 if (sc->dump == 0)
6410 {
6411 return 0;
6412 }
6413 else
6414 {
6415 const _kt_spagstack frame = sc->dump;
6416 if(frame->type == ksct_frame)
6417 {
6418 const struct dump_stack_frame *pdata = &frame->data.frame;
6419 sc->next_func = pdata->ff;
6420 sc->envir = pdata->envir;
6421
6422 _kt_spagstack final_frame = frame->next;
6423
6424 /* Add the collected pseudo-env elements */
6425 while(rv_pseudoenvs)
6426 {
6427 _kt_spagstack el = rv_pseudoenvs;
6428 _kt_spagstack new_top = rv_pseudoenvs->next;
6429 el->next = final_frame;
6430 final_frame = el;
6431 rv_pseudoenvs = new_top;
6432 }
6433 sc->dump = final_frame;
6434 return 1;
6435 }
6436 #ifdef PROFILING
6437 else
6438 if(frame->type == ksct_profile)
6439 {
6440 struct stack_profiling * pdata = &frame->data.profiling;
6441 k_profiling_done_frame(sc,pdata);
6442 sc->dump = frame->next;
6443 }
6444 #endif
6445 else if( frame->type == ksct_args )
6446 {
6447 struct stack_arg * old_pe = &frame->data.pseudoenv;
6448 if(old_pe->frame_depth > 0)
6449 {
6450 /* Make a copy, to be re-added lower down */
6451 _kt_spagstack new_pseudoenv =
6452 (_kt_spagstack)
6453 GC_MALLOC (sizeof (dump_stack_frame_cell));
6454 struct stack_arg * new_pe = &new_pseudoenv->data.pseudoenv;
6455 new_pe->vec = old_pe->vec;
6456 new_pe->frame_depth = old_pe->frame_depth - 1;
6457
6458 new_pseudoenv->type = ksct_args;
6459 new_pseudoenv->next = rv_pseudoenvs;
6460 rv_pseudoenvs = new_pseudoenv;
6461 }
6462
6463 sc->dump = frame->next;
6464 }
6465 else if( frame->type == ksct_arg_barrier )
6466 {
6467 errx( 0, "Not allowed");
6468 rv_pseudoenvs = 0;
6469 sc->dump = frame->next;
6470 }
6471 else
6472 {
6473 sc->dump = frame->next;
6474 }
6475 }
6476 }
6477 }
6478
6479 static _kt_spagstack
6480 klink_push_cont_aux
6481 (_kt_spagstack old_frame, pko ff, pko env)
6482 {
6483 _kt_spagstack frame =
6484 (_kt_spagstack)
6485 GC_MALLOC (sizeof (dump_stack_frame_cell));
6486 struct dump_stack_frame * pdata = &frame->data.frame;
6487 pdata->ff = ff;
6488 pdata->envir = env;
6489
6490 frame->type = ksct_frame;
6491 frame->next = old_frame;
6492 return frame;
6493 }
6494
6495 /* $$MOVE ME */
6496 static void
6497 klink_push_cont (klink * sc, pko ff)
6498 { sc->dump = klink_push_cont_aux(sc->dump, ff, sc->envir); }
6499
6500 /*_ , Dynamic bindings */
6501
6502 /* We do not pop dynamic bindings, only frames. */
6503 /* We deal with dynamic bindings in the context of the interpreter so
6504 that in the future we can cache them. */
6505 static void
6506 klink_push_dyn_binding (klink * sc, pko key, pko value)
6507 {
6508 _kt_spagstack frame =
6509 (_kt_spagstack)
6510 GC_MALLOC (sizeof (dump_stack_frame_cell));
6511 struct stack_binding *pdata = &frame->data.binding;
6512
6513 pdata->key = key;
6514 pdata->value = value;
6515
6516 frame->type = ksct_binding;
6517 frame->next = sc->dump;
6518 sc->dump = frame;
6519 }
6520
6521
6522 static pko
6523 klink_find_dyn_binding(klink * sc, pko key)
6524 {
6525 _kt_spagstack frame = sc->dump;
6526 while(1)
6527 {
6528 if (frame == 0)
6529 {
6530 return 0;
6531 }
6532 else
6533 {
6534 if(frame->type == ksct_binding)
6535 {
6536 const struct stack_binding *pdata = &frame->data.binding;
6537 if(pdata->key == key)
6538 { return pdata->value; }
6539 }
6540 frame = frame->next;
6541 }
6542 }
6543 }
6544 /*_ , Guards */
6545 /*_ . klink_push_guards */
6546 static _kt_spagstack
6547 klink_push_guards
6548 (_kt_spagstack old_frame, pko guards, pko envir, int exit)
6549 {
6550 _kt_spagstack frame =
6551 (_kt_spagstack)
6552 GC_MALLOC (sizeof (dump_stack_frame_cell));
6553 struct stack_guards * pdata = &frame->data.guards;
6554 pdata->guards = guards;
6555 pdata->envir = envir;
6556
6557 frame->type = exit ? ksct_exit_guards : ksct_entry_guards;
6558 frame->next = old_frame;
6559 return frame;
6560 }
6561 /*_ . get_guards_lo1st */
6562 /* Get a list of guard entries, root-most on top. */
6563 static pko
6564 get_guards_lo1st(_kt_spagstack frame)
6565 {
6566 pko list = K_NIL;
6567 for(; frame != 0; frame = frame->next)
6568 {
6569 if((frame->type == ksct_entry_guards) ||
6570 (frame->type == ksct_exit_guards))
6571 {
6572 list = cons(mk_continuation(frame), list);
6573 }
6574 }
6575
6576 return list;
6577 }
6578 /*_ , Args */
6579 /*_ . Misc */
6580 /*_ , set_nth_arg */
6581 #if 0
6582 /* Set the nth arg */
6583 /* Unused, probably for a while, probably will never be used in this
6584 form. */
6585 int
6586 set_nth_arg(klink * sc, int n, pko value)
6587 {
6588 _kt_spagstack frame = sc->dump;
6589 int i = 0;
6590 for(frame = sc->dump; frame != 0; frame = frame->next)
6591 {
6592 if(frame->type == ksct_args)
6593 {
6594 if( i == n )
6595 {
6596 frame->data.arg = value;
6597 return 1;
6598 }
6599 else
6600 { i++; }
6601 }
6602 }
6603 /* If we got here we never encountered the target. */
6604 return 0;
6605 }
6606 #endif
6607 /*_ . Store from value */
6608 /*_ , push_arg_raw */
6609 _kt_spagstack
6610 push_arg_raw(_kt_spagstack old_frame, pko value, int frame_depth)
6611 {
6612 _kt_spagstack frame =
6613 (_kt_spagstack)
6614 GC_MALLOC (sizeof (dump_stack_frame_cell));
6615
6616 frame->data.pseudoenv.vec = value;
6617 frame->data.pseudoenv.frame_depth = frame_depth;
6618 frame->type = ksct_args;
6619 frame->next = old_frame;
6620 return frame;
6621 }
6622 /*_ , k_do_store */
6623 /* T_STORE */
6624 pko
6625 k_do_store(klink * sc, pko functor, pko value)
6626 {
6627 WITH_PSYC_UNBOXED( kt_opstore, functor, T_STORE, sc );
6628 pko vec = do_destructure( sc, value, pdata->destr );
6629 /* Push that as arg */
6630 sc->dump = push_arg_raw (sc->dump, vec, pdata->frame_depth);
6631 return K_INERT;
6632 }
6633 /*_ . Load to value */
6634 /*_ , get_nth_arg */
6635 pko
6636 get_nth_arg( _kt_spagstack frame, int n )
6637 {
6638 int i = 0;
6639 for(; frame != 0; frame = frame->next)
6640 {
6641 if(frame->type == ksct_args)
6642 {
6643 if( i == n )
6644 { return frame->data.pseudoenv.vec; }
6645 else
6646 { i++; }
6647 }
6648 }
6649 /* If we got here we never encountered the target. */
6650 return 0;
6651 }
6652
6653 /*_ , k_load_recurse */
6654 /* $$IMPROVE ME Add a shortcut for accessing value without ever
6655 storing it. */
6656 pko
6657 k_load_recurse( _kt_spagstack frame, pko tree )
6658 {
6659 if(_get_type( tree) == T_PAIR)
6660 {
6661 WITH_PSYC_UNBOXED( kt_vec2, tree, T_PAIR, 0 );
6662 if( is_integer( pdata->_car ) && is_integer( pdata->_cdr ))
6663 {
6664 /* Pair of integers: Look up that item, look up secondary
6665 index, return it */
6666 const int n = ivalue( pdata->_car );
6667 const int m = ivalue( pdata->_cdr );
6668 pko vec = get_nth_arg( frame, n );
6669 assert( vec );
6670 assert( is_vector( vec ));
6671 pko value = basvector_elem( vec, m );
6672 assert( value );
6673 return value;
6674 }
6675 else
6676 {
6677 /* Pair, not integers: Explore car and cdr, return cons of them. */
6678 return cons(
6679 k_load_recurse( frame, pdata->_car ),
6680 k_load_recurse( frame, pdata->_cdr ));
6681 }
6682 }
6683 else
6684 {
6685 /* Anything else: Return it literally. */
6686 return tree;
6687 }
6688 }
6689
6690 /*_ , k_do_load */
6691 /* T_LOAD C-destructures as a singleton. It will contain a tree */
6692 /* This may largely take over for decurriers. */
6693 pko
6694 k_do_load(klink * sc, pko functor, pko value)
6695 {
6696 WITH_PSYC_UNBOXED( pko, functor, T_LOAD, sc );
6697 return k_load_recurse( sc->dump, *pdata );
6698 }
6699
6700 /*_ , Stack ancestry */
6701 /*_ . frame_is_ancestor_of */
6702 int frame_is_ancestor_of(_kt_spagstack frame, _kt_spagstack other)
6703 {
6704 /* Walk from other towards root. Return 1 if we ever encounter
6705 frame, otherwise 0. */
6706 for(; other != 0; other = other->next)
6707 {
6708 if(other == frame)
6709 { return 1; }
6710 }
6711 return 0;
6712 }
6713 /*_ . special_dynxtnt */
6714 /* Make a child of dynamic extent OUTER that evals with dynamic
6715 environment ENVIR continues normally to PROX_DEST. */
6716 _kt_spagstack special_dynxtnt
6717 (_kt_spagstack outer, _kt_spagstack prox_dest, pko envir)
6718 {
6719 return
6720 klink_push_cont_aux(outer,
6721 mk_curried(dcrry_2A01VLL,
6722 LIST1(mk_continuation(prox_dest)),
6723 REF_OPER(invoke_continuation)),
6724 envir);
6725 }
6726 /*_ . curr_frame_depth */
6727 int curr_frame_depth(_kt_spagstack frame)
6728 {
6729 /* Walk towards root, counting. */
6730 int count = 0;
6731 for(; frame != 0; frame = frame->next, count++)
6732 { }
6733 return count;
6734 }
6735 /*_ , Continuations */
6736 /*_ . Struct */
6737 typedef struct
6738 {
6739 _kt_spagstack frame;
6740 }
6741 continuation_t;
6742
6743 /*_ . Type */
6744 DEF_T_PRED (is_continuation, T_CONTINUATION,ground, "continuation?/o1");
6745 /*_ . Create */
6746 static pko
6747 mk_continuation (_kt_spagstack frame)
6748 {
6749 ALLOC_BOX_PRESUME (continuation_t, T_CONTINUATION);
6750 pdata->frame = frame;
6751 return PTR2PKO(pbox);
6752 }
6753 /*_ . Parts */
6754 static _kt_spagstack
6755 cont_dump (pko p)
6756 {
6757 WITH_PSYC_UNBOXED(continuation_t,p,T_CONTINUATION,0);
6758 return pdata->frame;
6759 }
6760
6761 /*_ . Continuations WRT interpreter */
6762 /*_ , current_continuation */
6763 static pko
6764 current_continuation (klink * sc)
6765 {
6766 return mk_continuation (sc->dump);
6767 }
6768 /*_ . Operations */
6769 /*_ , invoke_continuation */
6770 /* DOES NOT RETURN */
6771 /* Control is resumed at _klink_cycle */
6772
6773 /* Static and not directly available to Kernel, it's the eventual
6774 target of continuation_to_applicative. */
6775 SIG_CHKARRAY(invoke_continuation) =
6776 { REF_OPER(is_continuation), K_ANY, };
6777 DEF_SIMPLE_CFUNC(vs0a2,invoke_continuation,T_NO_K)
6778 {
6779 WITH_2_ARGS (p, value);
6780 assert(is_continuation(p));
6781 if(p)
6782 { sc->dump = cont_dump (p); }
6783 sc->value = value;
6784 longjmp (sc->pseudocontinuation, 1);
6785 }
6786 /*_ , add_guard */
6787 /* Add the appropriate guard, if any, and return the new proximate
6788 destination. */
6789 _kt_spagstack
6790 add_guard
6791 (_kt_spagstack prox_dest, _kt_spagstack to_contain,
6792 pko guard_list, pko envir, _kt_spagstack outer)
6793 {
6794 WITH_REPORTER(0);
6795 pko x;
6796 for(x = guard_list; x != K_NIL; x = cdr(x))
6797 {
6798 pko selector = car(car(x));
6799 assert(is_continuation(selector));
6800 if(frame_is_ancestor_of(cont_dump(selector), to_contain))
6801 {
6802 /* Call has to take place in the dynamic extent of the
6803 next frame around this set of guards, so that the
6804 interceptor has access to dynamic bindings, but then
6805 control has to continue normally to the next guard or
6806 finally to the destination.
6807
6808 So we extend the next frame with a call to
6809 invoke_continuation, currying the next destination in the
6810 chain. That does not check guards, so in effect it
6811 continues normally. Then we extend that with a call to
6812 the interceptor, currying an continuation->applicative of
6813 the guards' outer continuation.
6814
6815 NB, continuation->applicative is correct. It would be
6816 wrong to shortcircuit it. Although there are no guards
6817 between there and the outer continuation, the
6818 continuation we pass might be called from another dynamic
6819 context. But it needs to be unwrapped.
6820 */
6821 pko wrapped_interceptor = cadr(car(x));
6822 assert(is_applicative(wrapped_interceptor));
6823 pko interceptor = unwrap(0,wrapped_interceptor);
6824 assert(is_operative(interceptor));
6825
6826 _kt_spagstack med_frame =
6827 special_dynxtnt(outer, prox_dest, envir);
6828 prox_dest =
6829 klink_push_cont_aux(med_frame,
6830 mk_curried(dcrry_2VLLdotALL,
6831 LIST1(continuation_to_applicative(mk_continuation(outer))),
6832 interceptor),
6833 envir);
6834
6835 /* We use only the first match so end the loop. */
6836 break;
6837 }
6838 }
6839 return prox_dest;
6840 }
6841 /*_ , add_guard_chain */
6842 _kt_spagstack
6843 add_guard_chain
6844 (_kt_spagstack prox_dest, pko guard_frame_list, _kt_spagstack to_contain, int exit)
6845 {
6846 WITH_REPORTER(0);
6847 const enum klink_stack_cell_types tag
6848 = exit ? ksct_exit_guards : ksct_entry_guards ;
6849 for( ; guard_frame_list != K_NIL ; guard_frame_list = cdr(guard_frame_list))
6850 {
6851 _kt_spagstack guard_frame = cont_dump(car(guard_frame_list));
6852 if(guard_frame->type == tag)
6853 {
6854 struct stack_guards * pguards = &guard_frame->data.guards;
6855 prox_dest =
6856 add_guard(prox_dest,
6857 to_contain,
6858 pguards->guards,
6859 pguards->envir,
6860 exit ? guard_frame->next : guard_frame);
6861 }
6862 }
6863 return prox_dest;
6864 }
6865 /*_ , continue_abnormally */
6866 /*** Arrange to "walk" from current continuation to c, passing control
6867 thru appropriate guards. ***/
6868 SIG_CHKARRAY(continue_abnormally) =
6869 { REF_OPER(is_continuation), K_ANY, };
6870 /* I don't give this T_NO_K even though technically it longjmps
6871 rather than pushing into the eval loop. In the future we may
6872 distinguish those two cases. */
6873 DEF_SIMPLE_CFUNC(ps0a2,continue_abnormally,0)
6874 {
6875 WITH_2_ARGS(c,value);
6876 WITH_REPORTER(0);
6877 _kt_spagstack source = sc->dump;
6878 _kt_spagstack destination = cont_dump (c);
6879
6880 /*** Find the guard frames on the intermediate path. ***/
6881
6882 /* Control is exiting our current frame, so collect guards from
6883 there towards root. What we get is lowest first. */
6884 pko exiting_lo1st = get_guards_lo1st(source);
6885 /* Control is entering c's frame, so collect guards from there
6886 towards root. Again it's lowest first. */
6887 pko entering_lo1st = get_guards_lo1st(destination);
6888
6889 /* Remove identical entries from the top, thus removing any merged
6890 part. */
6891 while((exiting_lo1st != K_NIL) &&
6892 (entering_lo1st != K_NIL) &&
6893 (cont_dump(car(exiting_lo1st)) == cont_dump(car(entering_lo1st))))
6894 {
6895 exiting_lo1st = cdr(exiting_lo1st);
6896 entering_lo1st = cdr(entering_lo1st);
6897 }
6898
6899
6900
6901 /*** Construct a string of calls to the appropriate guards, ending
6902 at destination. We collect in the reverse of the order that
6903 they will be run, so collect from "entering" first, from
6904 highest to lowest, then collect from "exiting", from lowest to
6905 highest. ***/
6906
6907 _kt_spagstack prox_dest = destination;
6908
6909 pko entering_hi1st = reverse(sc, entering_lo1st);
6910 prox_dest = add_guard_chain(prox_dest, entering_hi1st, destination, 0);
6911 prox_dest = add_guard_chain(prox_dest, exiting_lo1st, source, 1);
6912
6913 invoke_continuation(sc, mk_continuation(prox_dest), value);
6914 return value; /* NOTREACHED */
6915 }
6916
6917 /*_ . Interface */
6918 /*_ , call_cc */
6919 SIG_CHKARRAY(call_cc) = { REF_OPER(is_combiner), };
6920 DEF_SIMPLE_APPLICATIVE(ps0a1,call_cc,0,ground, "call/cc")
6921 {
6922 WITH_1_ARGS(combiner);
6923 pko cc = current_continuation(sc);
6924 return kernel_eval_aux(sc,combiner,LIST1(cc),sc->envir);
6925 }
6926 /*_ , extend-continuation */
6927 /*_ . extend_continuation_aux */
6928 pko
6929 extend_continuation_aux(_kt_spagstack old_frame, pko a, pko env)
6930 {
6931 _kt_spagstack frame = klink_push_cont_aux(old_frame, a, env);
6932 return mk_continuation(frame);
6933 }
6934 /*_ . extend_continuation */
6935 SIG_CHKARRAY(extend_continuation) =
6936 { REF_OPER(is_continuation),
6937 REF_OPER(is_applicative),
6938 REF_KEY(K_TYCH_OPTIONAL),
6939 REF_OPER(is_environment),
6940 };
6941 DEF_SIMPLE_APPLICATIVE(ps0a3, extend_continuation,T_NO_K,ground, "extend-continuation")
6942 {
6943 WITH_3_ARGS(c, a, env);
6944 assert(is_applicative(a));
6945 if(env == K_INERT) { env = make_new_frame(K_NIL); }
6946 return extend_continuation_aux(cont_dump(c), unwrap(sc,a), env);
6947 }
6948 /*_ , continuation->applicative */
6949 SIG_CHKARRAY(continuation_to_applicative) = { REF_OPER(is_continuation), };
6950 DEF_SIMPLE_APPLICATIVE(p00a1,continuation_to_applicative,T_NO_K,ground, "continuation->applicative")
6951 {
6952 WITH_1_ARGS(c);
6953 return
6954 wrap(mk_curried (dcrry_2A01VLL, LIST1(c), REF_OPER(continue_abnormally)));
6955 }
6956
6957 /*_ , guard-continuation */
6958 /* Each guard list is repeat (list continuation applicative) */
6959 /* We'd like to spec that applicative take 2 args, a continuation and
6960 a value, and be wrapped exactly once. */
6961 SIG_CHKARRAY(guard_continuation) =
6962 { K_ANY, REF_OPER(is_continuation), K_ANY, };
6963 DEF_SIMPLE_APPLICATIVE(ps0a3,guard_continuation,T_NO_K,ground, "guard-continuation")
6964 {
6965 WITH_3_ARGS(entry_guards, c, exit_guards);
6966 /* The spec wants an outer continuation to keeps sets of guards from
6967 being mixed together if there are two calls to guard_continuation
6968 with the same c. But that happens naturally here, so it seems
6969 unneeded. */
6970
6971 /* $$IMPROVE ME Copy the es of both lists of guards. */
6972 _kt_spagstack frame = cont_dump(c);
6973 if(entry_guards != K_NIL)
6974 {
6975 frame = klink_push_guards(frame, entry_guards, sc->envir, 0);
6976 }
6977 if(exit_guards != K_NIL)
6978 {
6979 frame = klink_push_guards(frame, exit_guards, sc->envir, 1);
6980 }
6981
6982 pko inner_cont = mk_continuation(frame);
6983 return inner_cont;
6984 }
6985
6986 /*_ , guard-dynamic-extent */
6987 SIG_CHKARRAY(guard_dynamic_extent) =
6988 {
6989 REF_OPER(is_finite_list),
6990 REF_OPER(is_applicative),
6991 REF_OPER(is_finite_list),
6992 };
6993 /* DOES NOT RETURN */
6994 DEF_SIMPLE_APPLICATIVE(ps0a3,guard_dynamic_extent,0,ground, "guard-dynamic-extent")
6995 {
6996 WITH_3_ARGS(entry,app,exit);
6997 pko cont = guard_continuation(sc,entry,current_continuation(sc),exit);
6998 pko cont2 = extend_continuation(sc,cont, app, sc->envir);
6999 /* Skip directly into the new continuation, don't invoke the
7000 guards */
7001 invoke_continuation(sc,cont2, K_NIL);
7002 /* NOTREACHED */
7003 return 0;
7004 }
7005
7006 /*_ , Keyed dynamic bindings */
7007 /*_ . klink_kdb_binder */
7008 SIG_CHKARRAY(klink_kdb_binder) =
7009 { REF_OPER(is_key), K_ANY, REF_OPER(is_combiner), };
7010 DEF_SIMPLE_CFUNC(ps0a3,klink_kdb_binder,T_NO_K)
7011 {
7012 WITH_3_ARGS(key, value, combiner);
7013 /* Check that combiner is in fact a combiner. */
7014 if(!is_combiner(combiner))
7015 {
7016 KERNEL_ERROR_1(sc,
7017 "klink_kdb_binder: Arg 2 must be a combiner: ",
7018 combiner);
7019 }
7020 /* Push the new binding. */
7021 klink_push_dyn_binding(sc, key, value);
7022 /* $$IMPROVE ME In general, should can control calling better than
7023 this. Possibly do this thru invoke_continuation, except we're
7024 not arbitrarily changing continuations. */
7025 /* $$IMPROVE ME Want a better way to control what environment to
7026 push in. In fact, that's much like a dynamic variable. */
7027 /* $$IMPROVE ME Want a better and cheaper way to make empty
7028 environments. The vector thing should be controlled by a hint. */
7029 /* Make an empty static environment */
7030 new_frame_in_env(sc,K_NIL);
7031 /* Push combiner in that environment. */
7032 klink_push_cont(sc,combiner);
7033 /* And call it with no operands. */
7034 return K_NIL;
7035 }
7036 /* Combines with data to become "an applicative that takes two
7037 arguments, the second of which must be a oper. It calls its
7038 second argument with no operands (nil operand tree) in a fresh empty
7039 environment, and returns the result." */
7040 /*_ . klink_kdb_accessor */
7041 SIG_CHKARRAY(klink_kdb_accessor) =
7042 { REF_OPER(is_key), };
7043 DEF_SIMPLE_CFUNC(ps0a1,klink_kdb_accessor,T_NO_K)
7044 {
7045 WITH_1_ARGS(key);
7046 pko value = klink_find_dyn_binding(sc,key);
7047 if(!value)
7048 {
7049 KERNEL_ERROR_0(sc, "klink_kdb_accessor: No binding found");
7050 }
7051 return value;
7052 }
7053 /* Combines with data to become "an applicative that takes zero
7054 arguments. If the call to a occurs within the dynamic extent of a
7055 call to b, then a returns the value of the first argument passed to
7056 b in the smallest enclosing dynamic extent of a call to b. If the
7057 call to a is not within the dynamic extent of any call to b, an
7058 error is signaled."
7059 */
7060 /*_ . make_keyed_dynamic_variable */
7061 RGSTR(ground, "make-keyed-dynamic-variable", REF_OPER(make_keyed_dynamic_variable))
7062
7063 DEF_CFUNC(p00a0, make_keyed_dynamic_variable,K_NO_TYPE,T_NO_K)
7064 {
7065 return make_keyed_variable(
7066 REF_OPER(klink_kdb_binder),
7067 REF_OPER (klink_kdb_accessor));
7068 }
7069 /*_ , Profiling */
7070 #ifdef PROFILING
7071 /*_ . Structs */
7072 typedef struct profiling_data
7073 {
7074 int num_calls;
7075 long num_evalloops;
7076 } profiling_data;
7077 typedef struct
7078 {
7079 pko * objs;
7080 profiling_data * entries;
7081 int table_size;
7082 int alloced_size;
7083 } kt_profile_table;
7084 /*_ . Current data */
7085 /* This may be moved to per interpreter, or even more fine-grained. */
7086 /* This may not always be the way we get elapsed counts. */
7087 static long k_profiling_count = 0;
7088 static int k_profiling_p = 0; /* Are we profiling now? */
7089 /* If we are profiling, init this if it's not initted */
7090 static kt_profile_table k_profiling_table = { 0 };
7091 /*_ . Dealing with table (All will be shared with other lookup tables) */
7092 /*_ , Init */
7093 void
7094 init_profile_table(kt_profile_table * p_table, int initial_size)
7095 {
7096 p_table->objs = initial_size ?
7097 GC_MALLOC(sizeof(pko) * initial_size) : 0;
7098 p_table->entries = initial_size ?
7099 GC_MALLOC(sizeof(profiling_data) * initial_size) : 0;
7100 p_table->alloced_size = initial_size;
7101 p_table->table_size = 0;
7102 }
7103 /*_ , Increase its size */
7104 void
7105 enlarge_profile_table(kt_profile_table * p_table)
7106 {
7107 if(p_table->table_size == p_table->alloced_size)
7108 {
7109 p_table->alloced_size *= 2;
7110 p_table->entries = GC_REALLOC(p_table->entries, sizeof(profiling_data) * p_table->alloced_size);
7111 p_table->objs = GC_REALLOC(p_table->objs, sizeof(pko) * p_table->alloced_size);
7112 }
7113
7114
7115 }
7116 /*_ , Searching in it */
7117 /* Use objtable_get_index */
7118 /*_ . On the stack */
7119 static struct stack_profiling *
7120 klink_find_profile_in_frame (_kt_spagstack frame, pko ff)
7121 {
7122 for( ;
7123 (frame != 0) && (frame->type != ksct_frame) ;
7124 frame = frame->next)
7125 {
7126 if(frame->type == ksct_profile)
7127 {
7128 struct stack_profiling *pdata = &frame->data.profiling;
7129 if(pdata->ff == ff) { return pdata; }
7130 }
7131 }
7132 return 0;
7133 }
7134 /*_ . Profile collection operations */
7135 /*_ , When eval loop steps */
7136 void
7137 k_profiling_step(void)
7138 { k_profiling_count++; }
7139 /*_ , When we begin executing a frame */
7140 /* Push a stack_profiling cell onto the frame. */
7141
7142 void
7143 k_profiling_new_frame(klink * sc, pko ff)
7144 {
7145 if(!k_profiling_p) { return; }
7146 if(!is_operative(ff)) { return; }
7147 /* Do this only if ff is interesting (which for the moment means
7148 that it can be found in ground environment). */
7149 if(!reverse_binds_p(ff, ground_env) &&
7150 !reverse_binds_p(ff, print_lookup_unwraps) &&
7151 !reverse_binds_p(ff, print_lookup_to_xary))
7152 { return; }
7153 struct stack_profiling * found_profile =
7154 klink_find_profile_in_frame (sc->dump, ff);
7155 /* If the same combiner is already being profiled in this frame,
7156 don't add another copy. */
7157 if(found_profile)
7158 {
7159 /* $$IMPROVE ME Count tail calls */
7160 }
7161 else
7162 {
7163 /* Push a profiling frame */
7164 _kt_spagstack old_frame = sc->dump;
7165 _kt_spagstack frame =
7166 (_kt_spagstack)
7167 GC_MALLOC (sizeof (dump_stack_frame_cell));
7168 struct stack_profiling * pdata = &frame->data.profiling;
7169 pdata->ff = ff;
7170 pdata->initial_count = k_profiling_count;
7171 pdata->returned_p = 0;
7172 frame->type = ksct_profile;
7173 frame->next = old_frame;
7174 sc->dump = frame;
7175 }
7176 }
7177
7178 /*_ , When we pop a stack_profiling cell */
7179 void
7180 k_profiling_done_frame(klink * sc, struct stack_profiling * profile)
7181 {
7182 if(!k_profiling_p) { return; }
7183 profiling_data * pdata = 0;
7184 pko ff = profile->ff;
7185
7186 /* This stack_profiling cell is popped past but it might be used
7187 again if we re-enter, so mark it accordingly. */
7188 profile->returned_p = 1;
7189 if(k_profiling_table.alloced_size == 0)
7190 { init_profile_table(&k_profiling_table, 8); }
7191 else
7192 {
7193 int index = objtable_get_index(k_profiling_table.objs, k_profiling_table.table_size, ff);
7194 if(index >= 0)
7195 { pdata = &k_profiling_table.entries[index]; }
7196 }
7197
7198 /* Create it if needed */
7199 if(!pdata)
7200 {
7201 /* Increase size as needed */
7202 enlarge_profile_table(&k_profiling_table);
7203 /* Add entry */
7204 const int index = k_profiling_table.table_size;
7205 k_profiling_table.objs[index] = ff;
7206 k_profiling_table.table_size++;
7207 pdata = &k_profiling_table.entries[index];
7208 /* Initialize it here */
7209 pdata->num_calls = 0;
7210 pdata->num_evalloops = 0;
7211 }
7212
7213 /* Add to its counts: Num calls. Num eval-loops taken. */
7214 pdata->num_calls++;
7215 pdata->num_evalloops += k_profiling_count - profile->initial_count;
7216 }
7217 /*_ . Interface */
7218 /*_ , Turn profiling on */
7219 /* Maybe better as a command-line switch or binder. */
7220 SIG_CHKARRAY(profiling) = { REF_OPER(is_integer), };
7221 DEF_SIMPLE_APPLICATIVE (ps0a1, profiling,T_NO_K,ground, "profiling")
7222 {
7223 WITH_1_ARGS(profile_p);
7224 int pr = k_profiling_p;
7225 k_profiling_p = ivalue (profile_p);
7226 return mk_integer (pr);
7227 }
7228
7229 /*_ , Dumping profiling data */
7230 /* Return a list of the profiled combiners. */
7231 DEF_APPLICATIVE_W_DESTR(ps0a0,get_profiling_data,K_NO_TYPE,T_NO_K,ground,"get-profiling-data")
7232 {
7233 int index;
7234 pko result_list = K_NIL;
7235 for(index = 0; index < k_profiling_table.table_size; index++)
7236 {
7237 pko ff = k_profiling_table.objs[index];
7238 profiling_data * pdata = &k_profiling_table.entries[index];
7239
7240 /* Element format: (object num-calls num-evalloops) */
7241 result_list = cons(
7242 LIST3(ff,
7243 mk_integer(pdata->num_calls),
7244 mk_integer(pdata->num_evalloops)),
7245 result_list);
7246 }
7247 /* Don't care about order so no need to reverse the list. */
7248 return result_list;
7249 }
7250 /*_ . Reset profiling data */
7251 /*_ , Alternative definitions for no profiling */
7252 #else
7253 #define k_profiling_step()
7254 #define k_profiling_new_frame(DUMMY, DUMMY2)
7255 #endif
7256 /*_ . Error handling */
7257 /*_ , _klink_error_1 */
7258 static void
7259 _klink_error_1 (klink * sc, const char *s, pko a)
7260 {
7261 #if SHOW_ERROR_LINE
7262 const char *str = s;
7263 char sbuf[STRBUFFSIZE];
7264 pko the_inport = klink_find_dyn_binding(sc,K_INPORT);
7265 if (the_inport && (the_inport != K_NIL))
7266 {
7267 port * pt = portvalue(the_inport);
7268 /* Make sure error is not in REPL */
7269 if((pt->kind & port_file) && (pt->rep.stdio.file != stdin))
7270 {
7271 /* Count is 0-based but print it 1-based. */
7272 int ln = pt->rep.stdio.curr_line + 1;
7273 const char *fname = pt->rep.stdio.filename;
7274
7275 if (!fname)
7276 { fname = "<unknown>"; }
7277
7278 snprintf (sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
7279
7280 str = (const char *) sbuf;
7281 }
7282 }
7283 #else
7284 const char *str = s;
7285 #endif
7286 {
7287 pko err_arg;
7288 pko err_string = mk_string (str);
7289 if (a != 0)
7290 {
7291 err_arg = mcons (a, K_NIL);
7292 }
7293 else
7294 {
7295 err_arg = K_NIL;
7296 }
7297 err_arg = mcons (err_string, err_arg);
7298 invoke_continuation (sc, sc->error_continuation, err_arg);
7299 }
7300 /* NOTREACHED */
7301 return;
7302 }
7303
7304 /*_ , Default cheap error handlers */
7305 /*_ . kernel_err */
7306 DEF_CFUNC (ps0a1, kernel_err, K_ANY,0)
7307 {
7308 WITH_REPORTER(0);
7309 if(arg1 == K_NIL)
7310 {
7311 putstr (sc, "Error with no arguments. I know nut-ting!");
7312 return K_INERT;
7313 }
7314 if(!is_finite_list(arg1))
7315 {
7316 putstr (sc, "kernel_err: arg must be a finite list");
7317 return K_INERT;
7318 }
7319
7320 assert(is_pair(arg1));
7321 int got_string = is_string (car (arg1));
7322 pko args_x = got_string ? cdr (arg1) : arg1;
7323 const char *message = got_string ? string_value (car (arg1)) : " -- ";
7324
7325 putstr (sc, "Error: ");
7326 putstr (sc, message);
7327 return kernel_err_x (sc, args_x);
7328 }
7329
7330 /*_ . kernel_err_x */
7331 DEF_CFUNC (ps0a1, kernel_err_x, K_ANY_SINGLETON,0)
7332 {
7333 WITH_1_ARGS(args);
7334 WITH_REPORTER(0);
7335 putstr (sc, " ");
7336 if (args != K_NIL)
7337 {
7338 assert(is_pair(args));
7339 CONTIN_1 (dcrry_1dotALL, kernel_err_x, sc, cdr (args));
7340 klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
7341 CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, car (args));
7342 return K_INERT;
7343 }
7344 else
7345 {
7346 putstr (sc, "\n");
7347 return K_INERT;
7348 }
7349 }
7350 /*_ . kernel_err_return */
7351 DEF_CFUNC(ps0a1,kernel_err_return, K_ANY,0)
7352 {
7353 /* This should not set sc->done, because when it's called it still
7354 must print the error, which may require more eval loops. */
7355 sc->retcode = 1;
7356 return kernel_err(sc, arg1);
7357 }
7358 /*_ , Interface */
7359 /*_ . error */
7360 DEF_APPLICATIVE_W_DESTR(ps0a1,error,K_ANY,0,ground,"error")
7361 {
7362 WITH_1_ARGS(err_arg);
7363 invoke_continuation (sc, sc->error_continuation, err_arg);
7364 return 0; /* NOTREACHED */
7365 }
7366 /*_ . error-descriptor? */
7367 /* $$WRITE ME TO replace the punted version */
7368
7369 /*_ . Support for calling C functions */
7370
7371 /*_ , klink_call_cfunc_aux */
7372 static pko
7373 klink_call_cfunc_aux (klink * sc, const kt_cfunc * p_cfunc, pko * arg_array)
7374 {
7375 switch (p_cfunc->type)
7376 {
7377 /* For these macros, the arglist is parenthesized so is
7378 usable. */
7379
7380 /* ***************************************** */
7381 /* For function types returning bool as int (bXXaX) */
7382 #define CASE_CFUNCTYPE_bX(SUFFIX,ARGLIST) \
7383 case klink_ftype_##SUFFIX: \
7384 return kernel_bool(p_cfunc->func.f_##SUFFIX ARGLIST)
7385
7386 CASE_CFUNCTYPE_bX (b00a1, (arg_array[0]));
7387 CASE_CFUNCTYPE_bX (b00a2, (arg_array[0], arg_array[1]));
7388 CASE_CFUNCTYPE_bX (bs0a2, (sc, arg_array[0], arg_array[1]));
7389
7390 #undef CASE_CFUNCTYPE_bX
7391
7392
7393 /* ***************************************** */
7394 /* For function types returning pko (pXXaX) */
7395 #define CASE_CFUNCTYPE_pX(SUFFIX,ARGLIST) \
7396 case klink_ftype_##SUFFIX: \
7397 return p_cfunc->func.f_##SUFFIX ARGLIST
7398
7399 CASE_CFUNCTYPE_pX (p00a0, ());
7400 CASE_CFUNCTYPE_pX (p00a1, (arg_array[0]));
7401 CASE_CFUNCTYPE_pX (p00a2, (arg_array[0], arg_array[1]));
7402 CASE_CFUNCTYPE_pX (p00a3, (arg_array[0], arg_array[1], arg_array[2]));
7403
7404 CASE_CFUNCTYPE_pX (ps0a0, (sc));
7405 CASE_CFUNCTYPE_pX (ps0a1, (sc, arg_array[0]));
7406 CASE_CFUNCTYPE_pX (ps0a2, (sc, arg_array[0], arg_array[1]));
7407 CASE_CFUNCTYPE_pX (ps0a3, (sc, arg_array[0], arg_array[1], arg_array[2]));
7408 CASE_CFUNCTYPE_pX (ps0a4, (sc, arg_array[0], arg_array[1],
7409 arg_array[2], arg_array[3]));
7410 CASE_CFUNCTYPE_pX (ps0a5, (sc, arg_array[0], arg_array[1], arg_array[2], arg_array[3], arg_array[4]));
7411
7412 #undef CASE_CFUNCTYPE_pX
7413
7414
7415 /* ***************************************** */
7416 /* For function types returning void (vXXaX) */
7417 #define CASE_CFUNCTYPE_vX(SUFFIX,ARGLIST) \
7418 case klink_ftype_##SUFFIX: \
7419 p_cfunc->func.f_##SUFFIX ARGLIST; \
7420 return K_INERT
7421
7422 CASE_CFUNCTYPE_vX (vs0a2, (sc, arg_array[0], arg_array[1]));
7423 CASE_CFUNCTYPE_vX (vs0a3, (sc, arg_array[0], arg_array[1], arg_array[2]));
7424
7425 #undef CASE_CFUNCTYPE_vX
7426
7427 default:
7428 KERNEL_ERROR_0 (sc,
7429 "kernel_call: About that function type, I know nut-ting!");
7430 }
7431 }
7432 /*_ , klink_call_cfunc */
7433 static pko
7434 klink_call_cfunc (klink * sc, pko functor, pko env, pko args)
7435 {
7436 const kt_cfunc * p_cfunc = get_cfunc_func (functor);
7437 assert(p_cfunc->argcheck);
7438 const int max_args = 5;
7439 pko arg_array[max_args];
7440 pko extra_result;
7441 kt_destr_outcome outcome =
7442 destructure_to_array(sc,args,
7443 p_cfunc->argcheck,
7444 arg_array,
7445 max_args,
7446 &extra_result);
7447 switch (outcome)
7448 {
7449 case destr_success:
7450 return klink_call_cfunc_aux (sc, p_cfunc, arg_array);
7451 /* NOTREACHED */
7452 case destr_err:
7453 KERNEL_ERROR_1(sc, "kernel_call: argobject is the wrong type",
7454 LIST2(functor, extra_result));
7455 /* NOTREACHED */
7456 case destr_must_force:
7457 CONTIN_0_RAW (mk_cfunc_resume (functor), sc);
7458 schedule_rv_list (sc, extra_result);
7459 return K_INERT;
7460 default:
7461 KERNEL_ERROR_0(sc, "kernel_call: This case cannot happen");
7462 }
7463 }
7464
7465 /*_ , k_resume_to_cfunc */
7466 static pko
7467 k_resume_to_cfunc (klink * sc, pko functor, pko value)
7468 {
7469 assert_type (sc, value, T_DESTR_RESULT);
7470 const int max_args = 5;
7471 pko arg_array[max_args];
7472 {
7473 /** Fill arg_array **/
7474 WITH_REPORTER (sc);
7475 WITH_UNBOXED_UNSAFE (p_destr_result, kt_destr_result, value);
7476 basvector_fill_array(p_destr_result->_car, max_args, arg_array);
7477 /* Account for elements already used in initialization */
7478 int i = basvector_len (p_destr_result->_car);
7479 pko args;
7480 for (args = p_destr_result->_cdr; args != K_NIL; args = cdr (args), i++)
7481 {
7482 assert (i < max_args);
7483 arg_array [i] = car (args);
7484 }
7485 }
7486
7487 assert_type (0, functor, T_CFUNC_RESUME);
7488 WITH_UNBOXED_UNSAFE (p_cfunc, kt_cfunc, functor);
7489
7490 return klink_call_cfunc_aux (sc, p_cfunc, arg_array);
7491 }
7492 /*_ . Some decurriers */
7493 static pko
7494 dcrry_2A01VLL (klink * sc, pko args, pko value)
7495 {
7496 WITH_REPORTER(sc);
7497 return LIST2(car (args), value);
7498 }
7499 static pko dcrry_3A01dotVLL (klink * sc, pko args, pko value)
7500 {
7501 WITH_REPORTER(sc);
7502 return cons (car (args), value);
7503 }
7504 static pko
7505 dcrry_2CA01VLLA02 (klink * sc, pko args, pko value)
7506 {
7507 WITH_REPORTER(sc);
7508 return LIST2( cons (car (args), value), cadr (args));
7509 }
7510 /* May not be needed */
7511 static pko
7512 dcrry_3A01A02VLL (klink * sc, pko args, pko value)
7513 {
7514 WITH_REPORTER(sc);
7515 return LIST3(car (args), cadr (args), value);
7516 }
7517 static pko
7518 dcrry_2ALLVLL (klink * sc, pko args, pko value)
7519 {
7520 return LIST2(args, value);
7521 }
7522 static pko dcrry_2ALLV01 (klink * sc, pko args, pko value)
7523 {
7524 WITH_REPORTER(sc);
7525 return LIST2(args, car (value));
7526 }
7527
7528 static pko
7529 dcrry_NCVLLA01dotAX1 (klink * sc, pko args, pko value)
7530 {
7531 WITH_REPORTER(sc);
7532 return cons(cons (value, car (args)), cdr (args));
7533 }
7534 static pko dcrry_NdotALL (klink * sc, pko args, pko value)
7535 { return args; }
7536
7537 static pko dcrry_1ALL (klink * sc, pko args, pko value)
7538 { return cons( args, K_NIL ); }
7539
7540 static pko dcrry_5ALLdotVLL (klink * sc, pko args, pko value)
7541 { return cons (args, value); }
7542
7543 static pko dcrry_NVLLdotALL (klink * sc, pko args, pko value)
7544 { return cons (value, args); }
7545
7546 static pko
7547 dcrry_1VLL (klink * sc, pko args, pko value)
7548 { return LIST1 (value); }
7549
7550 /*_ . Defining */
7551 /*_ , Internal functions */
7552 /*_ . kernel_define_tree */
7553 SIG_CHKARRAY(kernel_define_tree) =
7554 { K_ANY, K_ANY, REF_OPER(is_environment), };
7555 DEF_SIMPLE_CFUNC(vs0a3,kernel_define_tree,T_NO_K)
7556 {
7557 WITH_REPORTER(0);
7558 WITH_3_ARGS(value, formal, env);
7559 if (is_pair (formal))
7560 {
7561 if (is_pair (value))
7562 {
7563 kernel_define_tree (sc, car (value), car (formal), env);
7564 kernel_define_tree (sc, cdr (value), cdr (formal), env);
7565 }
7566 else
7567 {
7568 _klink_error_1 (sc,
7569 "kernel_define_tree: value must be a pair: ", value);
7570 return; /* NOTREACHED */
7571 }
7572 }
7573 /* We can encounter NIL at the end of a non-dotted list, so mustn't
7574 try to bind it, and value list must end here too. */
7575 else if (formal == K_NIL)
7576 {
7577 if(value != K_NIL)
7578 {
7579 _klink_error_1 (sc,
7580 "kernel_define_tree: too many args: ", value);
7581 return; /* NOTREACHED */
7582 }
7583 }
7584 /* If formal is #ignore, don't try to bind it, do nothing. */
7585 else if (formal == K_IGNORE)
7586 {
7587 return;
7588 }
7589 /* If it's a symbol, bind it. */
7590 else if (is_symbol (formal))
7591 {
7592 kernel_define (env, formal, value);
7593 }
7594 else
7595 {
7596 _klink_error_1 (sc,
7597 "kernel_define_tree: can't bind to: ", formal);
7598 return; /* NOTREACHED */
7599 }
7600 }
7601
7602 /*_ . kernel_define */
7603 SIG_CHKARRAY(kernel_define) =
7604 {
7605 REF_OPER(is_environment),
7606 REF_OPER(is_symbol),
7607 K_ANY,
7608 };
7609 DEF_SIMPLE_CFUNC(p00a3,kernel_define,T_NO_K)
7610 {
7611 WITH_3_ARGS(env, symbol, value);
7612 assert(is_symbol(symbol));
7613 pko x = find_slot_in_env (env, symbol, 0);
7614 if (x != 0)
7615 {
7616 set_slot_in_env (x, value);
7617 }
7618 else
7619 {
7620 new_slot_spec_in_env (env, symbol, value);
7621 }
7622 return K_INERT;
7623 }
7624 void klink_define (klink * sc, pko symbol, pko value)
7625 { kernel_define(sc->envir,symbol,value); }
7626
7627 /*_ , Supporting kernel registerables */
7628 /*_ . eval_define */
7629 RGSTR(ground, "$define!", REF_OPER(eval_define))
7630 SIG_CHKARRAY(eval_define) =
7631 { K_ANY, K_ANY, };
7632 DEF_SIMPLE_CFUNC(ps0a2,eval_define,0)
7633 {
7634 pko env = sc->envir;
7635 WITH_2_ARGS(formal, expr);
7636 CONTIN_2(dcrry_3VLLdotALL,kernel_define_tree,sc,formal,env);
7637 /* Using args functionality:
7638 BEFORE:
7639 make 2 new slots
7640 put formal in 2,
7641 put env in 3,
7642
7643 RUN, in reverse order
7644 kernel_define_tree (CONTIN_0)
7645 make arglist from 3 args ($$WRITE MY SUPPORT) - or from 2 args and value.
7646 (The 2 slots will go here)
7647 put return value in new slot ($$WRITE MY SUPPORT)
7648 kernel_eval
7649
7650
7651 Possibly "make arglist" will be an array of integers, -1 meaning
7652 the current value. And on its own it could do decurrying.
7653 */
7654 return kernel_eval(sc,expr,env);
7655 }
7656 /*_ . set */
7657 RGSTR(ground, "$set!", REF_OPER(set))
7658 SIG_CHKARRAY(set) =
7659 { K_ANY, K_ANY, K_ANY, };
7660 DEF_SIMPLE_CFUNC(ps0a3,set,0)
7661 {
7662 pko env = sc->envir;
7663 WITH_3_ARGS(env_expr, formal, expr);
7664 /* Using args functionality:
7665
7666 RUN, in reverse order
7667 kernel_define_tree (CONTIN_0)
7668 make arglist from 3 args - or from 2 args and value.
7669 put return value in new slot
7670 kernel_eval
7671 make arglist from 1 arg
7672 env_expr in slot
7673 formal in slot
7674 put return value in new slot
7675 kernel_eval
7676 expr (Passed directly)
7677
7678 */
7679
7680 CONTIN_0(kernel_define_tree,sc);
7681 return
7682 kernel_mapeval(sc, K_NIL,
7683 LIST3(expr,
7684 LIST2(REF_OPER (arg1), formal),
7685 env_expr),
7686 env);
7687 }
7688
7689 /*_ . Misc Kernel functions */
7690 /*_ , tracing */
7691
7692 SIG_CHKARRAY(tracing) = { REF_OPER(is_integer), };
7693 DEF_SIMPLE_APPLICATIVE (ps0a1, tracing,T_NO_K,ground, "tracing")
7694 {
7695 WITH_1_ARGS(trace_p);
7696 int tr = sc->tracing;
7697 sc->tracing = ivalue (trace_p);
7698 return mk_integer (tr);
7699 }
7700
7701 /*_ , new_tracing */
7702
7703 SIG_CHKARRAY(new_tracing) = { REF_OPER(is_integer), };
7704 DEF_SIMPLE_APPLICATIVE (ps0a1, new_tracing,T_NO_K,ground, "new-tracing")
7705 {
7706 WITH_1_ARGS(trace_p);
7707 int tr = sc->new_tracing;
7708 sc->new_tracing = ivalue (trace_p);
7709 return mk_integer (tr);
7710 }
7711
7712
7713 /*_ , get-current-environment */
7714 DEF_APPLICATIVE_W_DESTR (ps0a0, get_current_environment, K_NO_TYPE,T_NO_K,ground, "get-current-environment")
7715 { return sc->envir; }
7716
7717 /*_ , arg1, $quote, list */
7718 DEF_APPLICATIVE_W_DESTR (ps0a1, arg1, K_ANY_SINGLETON,T_NO_K,ground, "identity")
7719 {
7720 WITH_1_ARGS(p);
7721 return p;
7722 }
7723 /* Same, unwrapped */
7724 RGSTR(ground, "$quote", REF_OPER(arg1))
7725
7726 /*_ , val2val */
7727 RGSTR(ground, "list", REF_APPL(val2val))
7728 /* The underlying C function here is "arg1", but it's called with
7729 the whole argobject as arg1 */
7730 /* K_ANY instead of REF_OPER(is_finite_list) because we deliberately allow
7731 non-lists and improper lists. */
7732 DEF_CFUNC_RAW(OPER(val2val),ps0a1,arg1,K_ANY,T_NO_K);
7733 DEF_BOXED_APPLICATIVE(val2val, REF_OPER (val2val));
7734
7735 /*_ , k_quit */
7736 RGSTR(ground,"exit",REF_OPER(k_quit))
7737 DEF_CFUNC(ps0a0,k_quit,K_NO_TYPE,0)
7738 {
7739 if(!nest_depth_ok_p(sc))
7740 { sc->retcode = 1; }
7741
7742 sc->done = 1;
7743 return K_INERT; /* Value is unused anyways */
7744 }
7745 /*_ , gc */
7746 RGSTR(ground,"gc",REF_OPER(k_gc))
7747 DEF_CFUNC(ps0a0,k_gc,K_NO_TYPE,0)
7748 {
7749 GC_gcollect();
7750 return K_INERT;
7751 }
7752
7753 /*_ , k_if */
7754
7755 RGSTR(ground, "$if", REF_OPER(k_if))
7756 FORWARD_DECL_CFUNC(static,ps0a3,k_if_literal);
7757 SIG_CHKARRAY(k_if) = { K_ANY, K_ANY, K_ANY, };
7758 DEF_SIMPLE_DESTR( k_if );
7759 SIG_CHAIN(k_if) =
7760 {
7761 /* Store (test consequent alternative) */
7762 ANON_STORE(REF_DESTR(k_if)),
7763
7764 ANON_LOAD(ANON_LIST1(ANON_LOAD_IX( 0, 0 ))),
7765 /* value = (test) */
7766
7767 REF_OPER(kernel_eval),
7768 /* test_result */
7769 /* Store (test_result) */
7770 ANON_STORE(K_ANY),
7771
7772 ANON_LOAD(ANON_LIST3(ANON_LOAD_IX( 0, 0 ),
7773 ANON_LOAD_IX( 1, 1 ),
7774 ANON_LOAD_IX( 1, 2 ))),
7775
7776 /* test_result, consequent, alternative */
7777 REF_OPER(k_if_literal),
7778 };
7779
7780 DEF_SIMPLE_CHAIN(k_if);
7781
7782 SIG_CHKARRAY(k_if_literal) = { REF_OPER(is_bool), K_ANY, K_ANY, };
7783 DEF_SIMPLE_CFUNC(ps0a3,k_if_literal,0)
7784 {
7785 WITH_3_ARGS(test, consequent, alternative);
7786 if(test == K_T) { return kernel_eval(sc, consequent, sc->envir); }
7787 if(test == K_F) { return kernel_eval(sc, alternative, sc->envir); }
7788 KERNEL_ERROR_1(sc,"Must be a boolean: ", test);
7789 }
7790
7791 /*_ . Routines for applicatives */
7792 BOX_OF_VOID (K_APPLICATIVE);
7793
7794 DEF_SIMPLE_PRED (is_applicative,T_NO_K,ground, "applicative?/o1")
7795 {
7796 WITH_1_ARGS(p);
7797 return is_encap (REF_KEY(K_APPLICATIVE), p);
7798 }
7799
7800 DEF_SIMPLE_PRED (is_combiner,T_NO_K,ground, "combiner?/o1")
7801 {
7802 WITH_1_ARGS(p);
7803 return is_applicative(p) || is_operative(p);
7804 }
7805
7806 SIG_CHKARRAY(wrap) = { REF_OPER(is_combiner) };
7807 DEF_SIMPLE_APPLICATIVE (p00a1, wrap,T_NO_K,ground, "wrap")
7808 {
7809 WITH_1_ARGS(p);
7810 return mk_encap (REF_KEY(K_APPLICATIVE), p);
7811 }
7812
7813 SIG_CHKARRAY(unwrap) = { REF_OPER(is_applicative) };
7814 DEF_SIMPLE_APPLICATIVE (ps0a1, unwrap,T_NO_K,ground, "unwrap")
7815 {
7816 WITH_1_ARGS(p);
7817 return unencap (sc, REF_KEY(K_APPLICATIVE), p);
7818 }
7819
7820 SIG_CHKARRAY(unwrap_all) = { REF_OPER(is_combiner) };
7821 DEF_SIMPLE_APPLICATIVE (p00a1, unwrap_all,T_NO_K,ground, "unwrap-all")
7822 {
7823 WITH_1_ARGS(p);
7824 /* Wrapping does not allowing circular wrapping, so this will
7825 terminate. */
7826 while(is_encap (REF_KEY(K_APPLICATIVE), p))
7827 { p = unencap (0, REF_KEY(K_APPLICATIVE), p); }
7828 return p;
7829 }
7830
7831
7832 /*_ . Operatives */
7833 /*_ , is_operative */
7834 /* This can be hacked quicker by suppressing 1 more bit and testing
7835 * just once. Requires keeping those T_ types co-ordinated, though. */
7836 DEF_SIMPLE_PRED (is_operative,T_NO_K,ground, "operative?/o1")
7837 {
7838 WITH_1_ARGS(p);
7839 return
7840 is_type (p, T_CFUNC) ||
7841 is_type (p, T_CURRIED) ||
7842 is_type (p, T_LISTLOOP) ||
7843 is_type (p, T_CHAIN) ||
7844 is_type (p, T_STORE) ||
7845 is_type (p, T_LOAD) ||
7846 is_type (p, T_TYPEP);
7847 }
7848
7849 /*_ . vau_1 */
7850 RGSTR(simple, "$vau/3", REF_OPER(vau_1))
7851
7852 /* This is a simple vau for bootstrap. It handles just a single
7853 expression. It's in ground for now, but will be only in
7854 low-for-optimization later */
7855
7856 /* $$IMPROVE ME Check that formals is a non-circular list with no
7857 duplicated symbols. If this check is typical for
7858 kernel_define_tree (probably), pass that an initially blank
7859 environment and it can check for symbols and error if they are
7860 already defined.
7861
7862 eformal is almost REF_OPER(is_symbol) but must accept #ignore also.
7863 */
7864 SIG_CHKARRAY(vau_1) = { K_ANY, K_ANY, K_ANY };
7865 DEF_SIMPLE_CFUNC (ps0a3, vau_1,0)
7866 {
7867 pko env = sc->envir;
7868 WITH_3_ARGS(formals, eformal, expression);
7869 /* This defines a vau object. Evaluating it is different.
7870 See 4.10.3 */
7871
7872 /* $$IMPROVE ME Could compile the expression now, but that's not so
7873 easy in Kernel. At least make a hook for that. */
7874
7875 /* Vau data is a list of the 4 things:
7876 The dynamic environment
7877 The eformal symbol
7878 An immutable copy of the formals es
7879 An immutable copy of the expression
7880
7881 $$IMPROVE ME Make not a list but a dedicated struct.
7882 */
7883 pko vau_data =
7884 LIST4(env,
7885 eformal,
7886 copy_es_immutable(sc, formals),
7887 copy_es_immutable (sc, expression));
7888 return
7889 mk_curried (dcrry_5VLLdotALL, vau_data, REF_OPER (eval_vau));
7890 }
7891
7892 /*_ . Evaluation, Kernel style */
7893 /*_ , Calling operatives */
7894 /*_ . eval_vau */
7895 /* Again, can't simply say REF_OPER(is_symbol) because it might be
7896 #ignore */
7897 SIG_CHKARRAY(eval_vau) =
7898 { K_ANY,
7899 REF_OPER(is_environment),
7900 K_ANY,
7901 K_ANY,
7902 K_ANY };
7903 DEF_SIMPLE_CFUNC (ps0a5, eval_vau,0)
7904 {
7905 pko env = sc->envir;
7906 WITH_5_ARGS(args, old_env, eformal, formals, expression);
7907
7908 /* Make a new environment, child of the static environment (which
7909 we get now while making the vau) and put it into the envir
7910 register. */
7911 new_frame_in_env (sc, old_env);
7912
7913 /* This will change in kernel_define, not here. */
7914 /* Bind the dynamic environment to the eformal symbol. */
7915 kernel_define_tree (sc, env, eformal, sc->envir);
7916
7917 /* Bind the formals (symbols) to the operands (values) treewise. */
7918 kernel_define_tree (sc, args, formals, sc->envir);
7919
7920 /* Evaluate the expression. */
7921 return kernel_eval (sc, expression, sc->envir);
7922 }
7923
7924 /*_ , Kernel eval mutual callers */
7925 /*_ . kernel_eval */
7926
7927 /* Optionally define a tracing kernel_eval */
7928 SIG_CHKARRAY(kernel_eval) = { K_ANY, REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
7929 DEF_SIMPLE_DESTR(kernel_eval);
7930 #if USE_TRACING
7931 FORWARD_DECL_CFUNC(static,ps0a2,kernel_real_eval);
7932 DEF_APPLICATIVE_W_DESTR (ps0a2, kernel_eval, REF_DESTR(kernel_eval),0,ground, "eval")
7933 {
7934 WITH_2_ARGS(form, env);
7935 /* $$RETHINK ME Set sc->envir here, remove arg from
7936 kernel_real_eval, and the tracing call will know its own env,
7937 it may just be a closure with form as value. */
7938 if(env == K_INERT)
7939 {
7940 env = sc->envir;
7941 }
7942 if (sc->tracing)
7943 {
7944 CONTIN_2 (dcrry_2dotALL, kernel_real_eval, sc, form, env);
7945 putstr (sc, "\nEval: ");
7946 CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, form);
7947 return K_INERT;
7948 }
7949 else
7950 {
7951 return kernel_real_eval (sc, form, env);
7952 }
7953 }
7954 #endif
7955
7956 /* Define either kernel_eval (if not defined above) or kernel_real_eval */
7957 #if USE_TRACING
7958 /* $$IMPROVE MY DESIGN Don't like the pointers being different
7959 levels of pointingness. In fact, we always potentially have
7960 tracing (or w/e) so let's lose the preprocessor condition. */
7961
7962 DEF_CFUNC (ps0a2, kernel_real_eval, REF_DESTR(kernel_eval),0)
7963 #else
7964 DEF_APPLICATIVE_W_DESTR (ps0a2, kernel_eval, REF_DESTR(kernel_eval),0,ground, "eval")
7965 #endif
7966 {
7967 WITH_REPORTER(0);
7968 WITH_2_ARGS(form, env);
7969
7970 /* Evaluate form in env */
7971 /* Arguments:
7972 form: form to be evaluated
7973 env: environment to evaluate it in.
7974 */
7975 assert (form);
7976 assert (env);
7977 /* $$IMPROVE ME Let this be done in kernel_eval and lose the env
7978 argument, here just assert that we have an environment. */
7979 if(env != K_INERT)
7980 {
7981 if (is_environment (env))
7982 { sc->envir = env; }
7983 else
7984 {
7985 KERNEL_ERROR_0 (sc, "eval: Arg 2 must be an environment:");
7986 }
7987 }
7988 /* symbol */
7989 if (is_symbol (form))
7990 {
7991 pko x = find_slot_in_env (env, form, 1);
7992 if (x != 0)
7993 {
7994 return slot_value_in_env (x);
7995 }
7996 else
7997 {
7998 KERNEL_ERROR_1 (sc, "eval: unbound variable:", form);
7999 }
8000 }
8001 /* pair */
8002 else if (is_pair (form))
8003 {
8004 CONTIN_2 (dcrry_3VLLdotALL, kernel_eval_aux, sc, cdr (form), env);
8005 return kernel_eval (sc, car (form), env);
8006 }
8007 /* Otherwise return the object literally. */
8008 else
8009 {
8010 return form;
8011 }
8012 }
8013 /*_ . kernel_eval_aux */
8014 /* The stage of `eval' when we've already decided that we're to use a
8015 combiner and what that combiner is. */
8016 /* $$IMPROVE ME Lose the env argument, it's always sc->envir */
8017 SIG_CHKARRAY(kernel_eval_aux) =
8018 { REF_OPER(is_combiner), K_ANY, REF_OPER(is_environment), };
8019 DEF_SIMPLE_DESTR(kernel_eval_aux);
8020 DEF_CFUNC (ps0a3, kernel_eval_aux, REF_DESTR(kernel_eval_aux),0)
8021 {
8022 WITH_3_ARGS(functor, args, env);
8023 assert (is_environment (env));
8024 /* Args:
8025 functor: what the car of the form has evaluated to.
8026 args: cdr of form, as yet unevaluated.
8027 env: environment to evaluate in.
8028 */
8029 k_profiling_new_frame(sc, functor);
8030 if(is_type(functor, T_CFUNC))
8031 {
8032 return klink_call_cfunc(sc, functor, env, args);
8033 }
8034 else if(is_type(functor, T_CFUNC_RESUME))
8035 {
8036 return k_resume_to_cfunc (sc, functor, args);
8037 }
8038 else if(is_type(functor, T_CURRIED))
8039 {
8040 return call_curried(sc, functor, args);
8041 }
8042 else if(is_type(functor, T_TYPEP))
8043 {
8044 /* $$MOVE ME Into something paralleling the other operative calls */
8045 /* $$IMPROVE ME Check arg number */
8046 WITH_REPORTER(0);
8047 if(!is_pair(args))
8048 { KERNEL_ERROR_1 (sc, "Takes one arg: ", functor); }
8049 return kernel_bool(call_T_typecheck(functor,car(args)));
8050 }
8051 else if(is_type(functor, T_LISTLOOP))
8052 {
8053 return eval_listloop(sc, functor,args);
8054 }
8055 else if(is_type(functor, T_CHAIN))
8056 {
8057 return eval_chain( sc, functor, args );
8058 }
8059 else if ( is_type( functor, T_STORE ))
8060 {
8061 return k_do_store( sc, functor, args );
8062 }
8063 else if ( is_type( functor, T_LOAD ))
8064 {
8065 return k_do_load( sc, functor, args );
8066 }
8067 else if (is_applicative (functor))
8068 {
8069 /* Operation:
8070 Get the underlying operative.
8071 Evaluate arguments (may make frames)
8072 Use the oper on the arguments
8073 */
8074 pko oper = unwrap (sc, functor);
8075 assert (oper);
8076 int4 metrics;
8077 get_list_metrics_aux(args, metrics);
8078 if(metrics[lm_cyc_len] != 0)
8079 {
8080 KERNEL_ERROR_1 (sc, "kernel_eval_aux: Arguments must be a list", args);
8081 }
8082 sc->envir = env; /* $$IMPROVE ME Treat this cache better */
8083 CONTIN_2 (dcrry_2CA01VLLA02, kernel_eval, sc, oper, env);
8084 #if USE_TRACING
8085 if (sc->tracing)
8086 {
8087 CONTIN_3 (dcrry_4dotALL, kernel_mapeval, sc, K_NIL, args, env);
8088 CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, args);
8089 putstr (sc, "\nApply to: ");
8090 return K_T;
8091 }
8092 else
8093 #endif
8094 { return kernel_mapeval (sc, K_NIL, args, env); }
8095 }
8096 else
8097 {
8098 KERNEL_ERROR_1 (sc, "eval: can't apply:", functor);
8099 }
8100 }
8101 /*_ , Eval mappers */
8102 /*_ . kernel_mapeval */
8103 /* Evaluate each datum in list arg2, Kernel-returning a list of the results. */
8104 SIG_CHKARRAY(kernel_mapeval) =
8105 { REF_OPER(is_finite_list), REF_OPER(is_finite_list), REF_OPER(is_environment), };
8106 DEF_SIMPLE_DESTR(kernel_mapeval);
8107 DEF_CFUNC (ps0a3, kernel_mapeval, REF_DESTR(kernel_mapeval),0)
8108 {
8109 WITH_REPORTER(0);
8110 WITH_3_ARGS(accum, args, env);
8111 assert (is_environment (env));
8112 /* Arguments:
8113 accum:
8114 * The list of evaluated arguments, in reverse order.
8115 * Purpose: Used as an accumulator.
8116
8117 args: list of forms to be evaluated.
8118 * Precondition: Must be a proper list (is_list must give true)
8119 * When called by itself: The forms that remain yet to be evaluated
8120
8121 env: The environment to evaluate in.
8122 */
8123
8124 /* If there are remaining arguments, arrange to evaluate one,
8125 add the result to accumulator, and return control here. */
8126 if (is_pair (args))
8127 {
8128 /* This can't be converted to a loop because we don't know
8129 whether kernel_eval_aux will create more frames. */
8130 CONTIN_3 (dcrry_3CVLLA01dotAX1,
8131 kernel_mapeval, sc, accum, cdr (args), env);
8132 return kernel_eval (sc, car (args), env);
8133 }
8134 /* If there are no remaining arguments, reverse the accumulator
8135 and return it. Can't reverse in place because other
8136 continuations might re-use the same accumulator state. */
8137 else if (args == K_NIL)
8138 { return reverse (sc, accum); }
8139 else
8140 {
8141 /* This shouldn't be reachable because we check for it being
8142 a list beforehand in kernel_eval_aux. */
8143 errx (4, "mapeval: arguments must be a list:");
8144 }
8145 }
8146
8147 RGSTR(ground,"$bad-sequence",REF_OPER(kernel_sequence))
8148 SIG_CHKARRAY(kernel_sequence) =
8149 { REF_KEY(K_TYCH_DOT), REF_OPER(is_countable_list), };
8150 DEF_SIMPLE_CFUNC(ps0a1,kernel_sequence,0)
8151 {
8152 WITH_1_ARGS(forms);
8153 /* Ultimately return #inert */
8154 /* $$IMPROVE ME This shouldn't accumulate args only to discard
8155 them. */
8156 CONTIN_0_RAW(mk_curried(dcrry_NdotALL, K_INERT, 0), sc);
8157 return kernel_mapeval(sc,K_NIL,forms,sc->envir);
8158 }
8159
8160 /*_ . kernel_mapand_aux */
8161 /* Call proc on each datum in args, Kernel-returning true if all
8162 succeed, otherwise false. */
8163 SIG_CHKARRAY(kernel_mapand_aux) =
8164 { REF_OPER(is_bool),
8165 REF_OPER(is_combiner),
8166 REF_OPER(is_finite_list),
8167 };
8168 DEF_SIMPLE_CFUNC (ps0a3, kernel_mapand_aux,0)
8169 {
8170 WITH_REPORTER(0);
8171 WITH_3_ARGS(ok, proc, args);
8172 /* Arguments:
8173 * succeeded:
8174 * Whether the last invocation of this succeeded. Initialize with
8175 K_T.
8176
8177 * proc: A boolean combiner (predicate) to apply to these objects
8178
8179 * args: list of objects to apply proc to
8180 * Precondition: Must be a proper list
8181 */
8182 if(ok == K_F)
8183 { return K_F; }
8184 if(ok != K_T)
8185 { KERNEL_ERROR_1(sc, "kernel_mapand_aux: Must be boolean: ", ok); }
8186 /* If there are remaining arguments, arrange to evaluate one and
8187 return control here. */
8188 if (is_pair (args))
8189 {
8190 /* This can't be converted to a loop because we don't know
8191 whether kernel_eval_aux will create more frames. */
8192 CONTIN_2 (dcrry_3VLLdotALL,
8193 kernel_mapand_aux, sc, proc, cdr (args));
8194 return kernel_eval_aux (sc, proc, car (args), sc->envir);
8195 }
8196 /* If there are no remaining arguments, return true. */
8197 else if (args == K_NIL)
8198 { return K_T; }
8199 else
8200 {
8201 /* This shouldn't be reachable because we check for it being a
8202 list beforehand. */
8203 errx (4, "mapbool: arguments must be a list:");
8204 }
8205 }
8206
8207 /*_ . kernel_mapand */
8208 SIG_CHKARRAY(kernel_mapand) =
8209 { REF_OPER(is_combiner),
8210 REF_OPER(is_finite_list),
8211 };
8212 DEF_SIMPLE_APPLICATIVE (ps0a2, kernel_mapand,0,simple, "every?/2-xary")
8213 {
8214 WITH_2_ARGS(proc, args);
8215 /* $$IMPROVE ME Get list metrics here and if we get a circular
8216 list, treat it correctly (How is TBD). */
8217 return kernel_mapand_aux(sc,REF_KEY(K_T), proc, args);
8218 }
8219 /*_ . kernel_mapor_aux */
8220 /* Call proc on each datum in args, Kernel-returning true if all
8221 succeed, otherwise false. */
8222 SIG_CHKARRAY(kernel_mapor_aux) =
8223 { REF_OPER(is_bool),
8224 REF_OPER(is_combiner),
8225 REF_OPER(is_finite_list),
8226 };
8227 DEF_SIMPLE_CFUNC (ps0a3, kernel_mapor_aux,0)
8228 {
8229 WITH_REPORTER(0);
8230 WITH_3_ARGS(ok, proc, args);
8231 /* Arguments:
8232 * succeeded:
8233 * Whether the last invocation of this succeeded. Initialize with
8234 K_T.
8235
8236 * proc: A boolean combiner (predicate) to apply to these objects
8237
8238 * args: list of objects to apply proc to
8239 * Precondition: Must be a proper list
8240 */
8241 if(ok == K_T)
8242 { return K_T; }
8243 if(ok != K_F)
8244 { KERNEL_ERROR_1(sc, "kernel_mapor_aux: Must be boolean: ", ok); }
8245 /* If there are remaining arguments, arrange to evaluate one and
8246 return control here. */
8247 if (is_pair (args))
8248 {
8249 /* This can't be converted to a loop because we don't know
8250 whether kernel_eval_aux will create more frames. */
8251 CONTIN_2 (dcrry_3VLLdotALL,
8252 kernel_mapor_aux, sc, proc, cdr (args));
8253 return kernel_eval_aux (sc, proc, car (args), sc->envir);
8254 }
8255 /* If there are no remaining arguments, return false. */
8256 else if (args == K_NIL)
8257 { return K_F; }
8258 else
8259 {
8260 /* This shouldn't be reachable because we check for it being a
8261 list beforehand. */
8262 errx (4, "mapbool: arguments must be a list:");
8263 }
8264 }
8265 /*_ . kernel_mapor */
8266 SIG_CHKARRAY(kernel_mapor) =
8267 { REF_OPER(is_combiner),
8268 REF_OPER(is_finite_list),
8269 };
8270 DEF_SIMPLE_APPLICATIVE (ps0a2, kernel_mapor,0,simple, "some?/2-xary")
8271 {
8272 WITH_2_ARGS(proc, args);
8273 /* $$IMPROVE ME Get list metrics here and if we get a circular
8274 list, treat it correctly (How is TBD). */
8275 return kernel_mapor_aux(sc,REF_KEY(K_F), proc, args);
8276 }
8277
8278 /*_ , Kernel combiners */
8279 /*_ . $and? */
8280 /* $$IMPROVE ME Make referring to curried operatives neater. */
8281 RGSTR(ground, "$and?", REF_OBJ(k_oper_andp))
8282 DEF_BOXED_CURRIED(k_oper_andp,
8283 dcrry_2ALLVLL,
8284 REF_OPER(kernel_internal_eval),
8285 REF_OPER(kernel_mapand));
8286
8287 /*_ . $or? */
8288 RGSTR(ground, "$or?", REF_OBJ(k_oper_orp))
8289 DEF_BOXED_CURRIED(k_oper_orp,
8290 dcrry_2ALLVLL,
8291 REF_OPER(kernel_internal_eval),
8292 REF_OPER(kernel_mapor));
8293
8294 /*_ , map */
8295 /*_ . k_counted_map_aux */
8296 /* $$USE ME MORE Export both to simple: "counted-map1-car"
8297 "counted-map1-cdr" */
8298 pko
8299 k_counted_map_car(klink * sc, int count, pko list, _kt_tag t_enum)
8300 {
8301 int i;
8302 pko rv_result = K_NIL;
8303 for(i = 0; i < count; ++i, list = pair_cdr(0, list))
8304 {
8305 assert(is_pair(list));
8306 pko obj = pair_car(0, list);
8307 rv_result = v2cons (t_enum, pair_car(sc, obj), rv_result);
8308 }
8309
8310 /* Reverse the list in place. */
8311 return unsafe_v2reverse_in_place(K_NIL, rv_result);
8312 }
8313
8314 pko
8315 k_counted_map_cdr(klink * sc, int count, pko list, _kt_tag t_enum)
8316 {
8317 int i;
8318 pko rv_result = K_NIL;
8319 for(i = 0; i < count; ++i, list = pair_cdr(0, list))
8320 {
8321 assert(is_pair(list));
8322 pko obj = pair_car(0, list);
8323 rv_result = v2cons (t_enum, pair_cdr(sc, obj), rv_result);
8324 }
8325
8326 /* Reverse the list in place. */
8327 return unsafe_v2reverse_in_place(K_NIL, rv_result);
8328 }
8329
8330 /* Evaluate COUNT datums in list ARGS, Kernel-returning a list of the
8331 results. */
8332 SIG_CHKARRAY(k_counted_map_aux) =
8333 { REF_OPER(is_finite_list),
8334 REF_OPER(is_integer),
8335 REF_OPER(is_integer),
8336 REF_OPER(is_operative),
8337 REF_OPER(is_finite_list),
8338 };
8339 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_map_aux, 0,simple, "counted-map/5")
8340 {
8341 WITH_5_ARGS(accum, count, len, oper, args);
8342 assert (is_integer (count));
8343 /* $$IMPROVE ME Check the other args too */
8344
8345 /* Arguments:
8346 accum:
8347 * The list of evaluated arguments, in reverse order.
8348 * Purpose: Used as an accumulator.
8349
8350 count:
8351 * The number of arguments remaining
8352
8353 len:
8354 * The effective length of args.
8355
8356 oper
8357 * An xary operative
8358
8359 args: list of lists of arguments to this.
8360
8361 * Precondition: Must be a proper list (is_finite_list must give
8362 true). args will not be cyclic, we'll check for and handle
8363 encycling outside of here.
8364 */
8365
8366 /* If there are remaining arguments, arrange to operate on one, cons
8367 the result to accumulator, and return control here. */
8368 if (ivalue (count) > 0)
8369 {
8370 assert(is_pair(args));
8371 int len_v = ivalue(len);
8372 /* This can't be converted to a loop because we don't know
8373 whether kernel_eval_aux will create more frames.
8374
8375 $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8376 */
8377 CONTIN_5 (dcrry_5CVLLA01dotAX1,
8378 k_counted_map_aux, sc, accum,
8379 mk_integer(ivalue(count) - 1),
8380 len,
8381 oper,
8382 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8383
8384 return kernel_eval_aux (sc,
8385 oper,
8386 k_counted_map_car(sc, len_v, args, T_PAIR),
8387 sc->envir);
8388 }
8389 /* If there are no remaining arguments, reverse the accumulator
8390 and return it. Can't reverse in place because other
8391 continuations might re-use the same accumulator state. */
8392 else
8393 { return reverse (sc, accum); }
8394 }
8395
8396 /*_ , every? */
8397 /*_ . counted-every?/5 */
8398 SIG_CHKARRAY(k_counted_every) =
8399 { REF_OPER(is_bool),
8400 REF_OPER(is_integer),
8401 REF_OPER(is_integer),
8402 REF_OPER(is_operative),
8403 REF_OPER(is_finite_list),
8404 };
8405 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_every,0,simple,"counted-every?/5")
8406 {
8407 WITH_5_ARGS(ok, count, len, oper, args);
8408 assert (is_bool (ok));
8409 assert (is_integer (count));
8410 assert (is_integer (len));
8411
8412 /* Arguments:
8413 * succeeded:
8414 * Whether the last invocation of this succeeded. Initialize with
8415 K_T.
8416
8417 count:
8418 * The number of arguments remaining
8419
8420 len:
8421 * The effective length of args.
8422
8423 oper
8424 * An xary operative
8425
8426 args: list of lists of arguments to this.
8427
8428 * Precondition: Must be a proper list (is_finite_list must give
8429 true). args will not be cyclic, we'll check for and handle
8430 encycling outside of here.
8431 */
8432
8433 if(ok == K_F)
8434 { return K_F; }
8435 if(ok != K_T)
8436 { KERNEL_ERROR_1(sc, "k_counted_every: Must be boolean: ", ok); }
8437
8438 /* If there are remaining arguments, arrange to evaluate one and
8439 return control here. */
8440 if (ivalue (count) > 0)
8441 {
8442 assert(is_pair(args));
8443 int len_v = ivalue(len);
8444 /* This can't be converted to a loop because we don't know
8445 whether kernel_eval_aux will create more frames.
8446
8447 $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8448 */
8449 CONTIN_4 (dcrry_4VLLdotALL,
8450 k_counted_every, sc,
8451 mk_integer(ivalue(count) - 1),
8452 len,
8453 oper,
8454 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8455
8456 return kernel_eval_aux (sc,
8457 oper,
8458 k_counted_map_car(sc, len_v, args, T_PAIR),
8459 sc->envir);
8460 }
8461 /* If there are no remaining arguments, return true. */
8462 else
8463 { return K_T; }
8464 }
8465
8466 /*_ , some? */
8467 /*_ . counted-some?/5 */
8468 SIG_CHKARRAY(k_counted_some) =
8469 { REF_OPER(is_bool),
8470 REF_OPER(is_integer),
8471 REF_OPER(is_integer),
8472 REF_OPER(is_operative),
8473 REF_OPER(is_finite_list),
8474 };
8475 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_some,0,simple,"counted-some?/5")
8476 {
8477 WITH_5_ARGS(ok, count, len, oper, args);
8478 assert (is_bool (ok));
8479 assert (is_integer (count));
8480 assert (is_integer (len));
8481
8482 if(ok == K_T)
8483 { return K_T; }
8484 if(ok != K_F)
8485 { KERNEL_ERROR_1(sc, "k_counted_some: Must be boolean: ", ok); }
8486
8487 /* If there are remaining arguments, arrange to evaluate one and
8488 return control here. */
8489 if (ivalue (count) > 0)
8490 {
8491 assert(is_pair(args));
8492 int len_v = ivalue(len);
8493 /* This can't be converted to a loop because we don't know
8494 whether kernel_eval_aux will create more frames.
8495
8496 $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8497 */
8498 CONTIN_4 (dcrry_4VLLdotALL,
8499 k_counted_some, sc,
8500 mk_integer(ivalue(count) - 1),
8501 len,
8502 oper,
8503 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8504
8505 return kernel_eval_aux (sc,
8506 oper,
8507 k_counted_map_car(sc, len_v, args, T_PAIR),
8508 sc->envir);
8509 }
8510 /* If there are no remaining arguments, return false. */
8511 else
8512 { return K_F; }
8513 }
8514
8515
8516 /*_ . Klink top level */
8517 /*_ , kernel_repl */
8518 DEF_CFUNC(ps0a0, kernel_repl, K_NO_TYPE,0)
8519 {
8520 /* If we reached the end of file, this loop is done. */
8521 port *pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
8522
8523 if (pt->kind & port_saw_EOF)
8524 { return K_INERT; }
8525
8526 putstr (sc, "\n");
8527 putstr (sc, prompt);
8528
8529 assert (is_environment (sc->envir));
8530
8531 /* Arrange another iteration */
8532 CONTIN_0 (kernel_repl, sc);
8533 klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
8534 klink_push_cont(sc, REF_OBJ(print_value));
8535 #if USE_TRACING
8536 CONTIN_1 (dcrry_2A01VLL, tracing_say, sc, mk_string("\nGives: "));
8537 #endif
8538 CONTIN_0 (kernel_internal_eval, sc);
8539 CONTIN_0 (kernel_read_internal, sc);
8540 return K_INERT;
8541 }
8542
8543 /*_ , kernel_rel */
8544 static const kt_vector rel_chain =
8545 {
8546 3,
8547 ((pko[])
8548 {
8549 REF_OPER(kernel_read_internal),
8550 REF_OPER(kernel_internal_eval),
8551 REF_OPER(kernel_rel),
8552 }),
8553 };
8554
8555 DEF_CFUNC(ps0a0, kernel_rel, K_NO_TYPE,0)
8556 {
8557 /* If we reached the end of file, this loop is done. */
8558 port *pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
8559
8560 if (pt->kind & port_saw_EOF)
8561 { return K_INERT; }
8562
8563 assert (is_environment (sc->envir));
8564
8565 #if 1
8566 schedule_chain( sc, &rel_chain);
8567 #else
8568 /* Arrange another iteration */
8569 CONTIN_0 (kernel_rel, sc);
8570 CONTIN_0 (kernel_internal_eval, sc);
8571 CONTIN_0 (kernel_read_internal, sc);
8572 #endif
8573 return K_INERT;
8574 }
8575
8576 /*_ , kernel_internal_eval */
8577 /* Convert the aftermath of kernel_read_internal to something kernel_eval
8578 can accept. */
8579 /* $$IMPROVE ME realize this as a currier. But it's not a curried
8580 object as such because it carries no internal data. */
8581 DEF_CFUNC (ps0a1, kernel_internal_eval, K_ANY,0)
8582 {
8583 pko value = arg1;
8584 if( sc->new_tracing )
8585 { klink_push_dyn_binding( sc, K_TRACING, K_T ); }
8586 return kernel_eval (sc, value, sc->envir);
8587 }
8588
8589 /*_ . Constructing environments */
8590 /*_ , Declarations for built-in environments */
8591 /* These are initialized before they are registered. */
8592 static pko print_lookup_env = 0;
8593 static pko all_builtins_env = 0;
8594 static pko ground_env = 0;
8595 #define unsafe_env ground_env
8596 #define simple_env ground_env
8597 static pko typecheck_env_syms = 0;
8598
8599 /*_ , What to include */
8600 #ifndef COLLECT_RGSTRS /* If we're collecting, these files may not
8601 have been generated yet */
8602 const kernel_registerable preregister[] =
8603 {
8604 /* $$MOVE ME These others will move into dedicated arrays, and be
8605 combined so that they can all be seen in init.krn but not in
8606 ground env. */
8607 #include "registerables/ground.inc"
8608 #include "registerables/unsafe.inc"
8609 #include "registerables/simple.inc"
8610 /* $$TRANSITIONAL */
8611 { "type?", REF_APPL(typecheck), },
8612 { "do-destructure", REF_APPL(do_destructure), },
8613 };
8614
8615 const kernel_registerable all_builtins[] =
8616 {
8617 #include "registerables/all-builtins.inc"
8618 };
8619
8620 const kernel_registerable print_lookup_rgsts[] =
8621 {
8622 { "#f", REF_KEY(K_F), },
8623 { "#t", REF_KEY(K_T), },
8624 { "#inert", REF_KEY(K_INERT), },
8625 { "#ignore", REF_KEY(K_IGNORE), },
8626
8627 { "$quote", REF_OPER(arg1), },
8628
8629 /* $$IMPROVE ME Add the other quote-like symbols here. */
8630 /* quasiquote, unquote, unquote-splicing */
8631
8632 };
8633
8634 const kernel_registerable typecheck_syms_rgsts[] =
8635 {
8636 #include "registerables/type-keys.inc"
8637 };
8638 #endif
8639
8640
8641 /*_ , How to add */
8642
8643 /* Bind each of an array of kernel_registerables into env. */
8644 void
8645 k_register_list (const kernel_registerable * list, int count, pko env)
8646 {
8647 int i;
8648 assert(list);
8649 assert (is_environment (env));
8650 for (i = 0; i < count; i++)
8651 {
8652 kernel_define (env, mk_symbol (list[i].name), list[i].data);
8653 }
8654 }
8655
8656 /*_ , k_regstrs_to_env */
8657 pko
8658 k_regstrs_to_env(const kernel_registerable * list, int count)
8659 {
8660 pko env = make_new_frame(K_NIL);
8661 k_register_list (list, count, env);
8662 return env;
8663 }
8664
8665 #define K_REGSTRS_TO_ENV(RGSTRS)\
8666 k_regstrs_to_env(RGSTRS, sizeof (RGSTRS) / sizeof (RGSTRS[0]))
8667 /*_ , setup_print_secondary_lookup */
8668 static pko print_lookup_unwraps = 0;
8669 static pko print_lookup_to_xary = 0;
8670 void
8671 setup_print_secondary_lookup(void)
8672 {
8673 /* Quick and dirty: Set up tables corresponding to the ground env
8674 and put the registering stuff in them. */
8675 /* What this really accomplishes is to make prepared lookup tables
8676 available for particular print operations. Later we'll use a
8677 more general approach and this will become just a cache. */
8678 print_lookup_unwraps = make_new_frame(K_NIL);
8679 print_lookup_to_xary = make_new_frame(K_NIL);
8680 int i;
8681 const kernel_registerable * list = preregister;
8682 int count = sizeof (preregister) / sizeof (preregister[0]);
8683 for (i = 0; i < count; i++)
8684 {
8685 pko obj = list[i].data;
8686 if(is_applicative(obj))
8687 {
8688 kernel_define (print_lookup_unwraps,
8689 mk_symbol (list[i].name),
8690 unwrap(0,obj));
8691 }
8692 pko xary = k_to_trivpred(obj);
8693 if((xary != K_NIL) && xary != obj)
8694 {
8695 kernel_define (print_lookup_to_xary,
8696 mk_symbol (list[i].name),
8697 xary);
8698 }
8699 }
8700 }
8701
8702 /*_ , make-kernel-standard-environment */
8703 /* Though it would be neater for this to define ground environment if
8704 there is none, that would mean it would need the eval loop and so
8705 couldn't be done early. So it relies on the ground environment
8706 being already defined. */
8707 RGSTR(ground,"make-kernel-standard-environment", REF_OPER(mk_std_environment))
8708 DEF_CFUNC(p00a0, mk_std_environment, K_NO_TYPE,T_NO_K)
8709 {
8710 assert(ground_env);
8711 return make_new_frame(ground_env);
8712 }
8713
8714 /*_ . The eval cycle */
8715 /*_ , Helpers */
8716 /*_ . Make an error continuation */
8717 static void
8718 klink_record_error_cont (klink * sc, pko error_continuation)
8719 {
8720 /* Record error continuation. */
8721 kernel_define (sc->envir,
8722 mk_symbol ("error-continuation"),
8723 error_continuation);
8724 /* Also record it in interpreter, so built-ins can see it w/o
8725 lookup. */
8726 sc->error_continuation = error_continuation;
8727 }
8728
8729 /*_ , Entry points */
8730 /*_ . Eval cycle that restarts on error */
8731 static void
8732 klink_cycle_restarting (klink * sc, pko combiner)
8733 {
8734 assert(is_combiner(combiner));
8735 assert(is_environment(sc->envir));
8736 /* Arrange to stop if we ever reach where we started. */
8737 klink_push_cont (sc, REF_OPER (k_quit));
8738
8739 /* Grab root continuation. */
8740 kernel_define (sc->envir,
8741 mk_symbol ("root-continuation"),
8742 current_continuation (sc));
8743
8744 /* Make main continuation */
8745 klink_push_cont (sc, combiner);
8746
8747 /* Make error continuation on top of main continuation. */
8748 pko error_continuation =
8749 extend_continuation_aux(sc->dump, REF_OPER(kernel_err), sc->envir);
8750
8751 klink_record_error_cont(sc, error_continuation);
8752
8753 /* Conceptually sc->retcode is a keyed dynamic variable that
8754 kernel_err sets. */
8755 sc->retcode = 0;
8756 _klink_cycle (sc);
8757 /* $$RECONSIDER ME Maybe indicate quit value */
8758 }
8759 /*_ . Eval cycle that terminates on error */
8760 static int
8761 klink_cycle_no_restart (klink * sc, pko combiner)
8762 {
8763 assert(is_combiner(combiner));
8764 assert(is_environment(sc->envir));
8765 /* Arrange to stop if we ever reach where we started. */
8766 klink_push_cont (sc, REF_OPER (k_quit));
8767
8768 /* Grab root continuation. */
8769 kernel_define (sc->envir,
8770 mk_symbol ("root-continuation"),
8771 current_continuation (sc));
8772
8773 /* Make error continuation that quits. */
8774 pko error_continuation =
8775 extend_continuation_aux(sc->dump, REF_OPER(kernel_err_return), sc->envir);
8776
8777 klink_record_error_cont(sc, error_continuation);
8778
8779 klink_push_cont (sc, combiner);
8780
8781 /* Conceptually sc->retcode is a keyed dynamic variable that
8782 kernel_err sets. Actually it's entirely cached in the
8783 interpreter. */
8784 sc->retcode = 0;
8785 _klink_cycle (sc);
8786 return sc->retcode;
8787 }
8788
8789 /*_ , _klink_cycle (Don't use this directly) */
8790 static void
8791 _klink_cycle (klink * sc)
8792 {
8793 pko value = K_INERT;
8794
8795 sc->done = 0;
8796 while (!sc->done)
8797 {
8798 int i = setjmp (sc->pseudocontinuation);
8799 if (i == 0)
8800 {
8801 k_profiling_step();
8802 int got_new_frame = klink_pop_cont (sc);
8803 /* $$RETHINK ME Is this test still needed? Could be just
8804 an assertion. */
8805 if (got_new_frame)
8806 {
8807 /* $$IMPROVE ME Instead, a function that governs
8808 whether to eval. */
8809 if (sc->new_tracing)
8810 {
8811 if(_get_type( sc->next_func ) == T_NOTRACE )
8812 {
8813 sc->next_func = notrace_comb( sc->next_func );
8814 goto normal;
8815 }
8816 pko tracing =
8817 klink_find_dyn_binding(sc, K_TRACING );
8818 /* Now we know the other branch should have been
8819 taken. */
8820 if( !tracing || ( tracing == K_F ))
8821 { goto normal; }
8822
8823 /* Enqueue a version that will execute without
8824 tracing. Its descendants will be traced. */
8825 CONTIN_0_RAW (mk_notrace(mk_curried(dcrry_1dotALL,
8826 value,
8827 mk_notrace(sc->next_func))),
8828 sc );
8829 switch (_get_type (sc->next_func))
8830 {
8831 case T_LOAD:
8832 putstr (sc, "\nLoad ");
8833 break;
8834
8835 case T_STORE:
8836 putstr (sc, "\nStore ");
8837 break;
8838
8839 case T_CURRIED:
8840 putstr (sc, "\nDecurry ");
8841 break;
8842
8843 default:
8844 /* Print tracing */
8845 {
8846 /* Find and print current frame depth */
8847 int depth = curr_frame_depth (sc->dump);
8848 char * str = sc->strbuff;
8849 snprintf (str, STRBUFFSIZE, "\n%d: ", depth);
8850 putstr (sc, str);
8851 }
8852 klink_push_dyn_binding (sc, K_TRACING, K_F);
8853 putstr (sc, "Eval: ");
8854 value = kernel_print_sexp (sc,
8855 cons (sc->next_func, value),
8856 K_INERT);
8857 }
8858 }
8859 else
8860 {
8861 normal:
8862 value = kernel_eval_aux (sc, sc->next_func, value, sc->envir);
8863 }
8864
8865 }
8866 /* Stop looping if stack is empty. */
8867 else
8868 { break; }
8869 }
8870 else
8871 /* Otherwise something jumped to a continuation. Get the
8872 value and keep looping. */
8873 {
8874 value = sc->value;
8875 }
8876 }
8877 /* In case we're called nested in another _klink_cycle, don't
8878 affect it. */
8879 sc->done = 0;
8880 }
8881
8882 /*_ . Vtable interface */
8883 /* initialization of Klink */
8884 #if USE_INTERFACE
8885
8886 static struct klink_interface vtbl =
8887 {
8888 klink_define,
8889 mk_mutable_pair,
8890 mk_pair,
8891 mk_integer,
8892 mk_real,
8893 mk_symbol,
8894 mk_string,
8895 mk_counted_string,
8896 mk_character,
8897 mk_vector,
8898 putstr,
8899 putcharacter,
8900
8901 is_string,
8902 string_value,
8903 is_number,
8904 nvalue,
8905 ivalue,
8906 rvalue,
8907 is_integer,
8908 is_real,
8909 is_character,
8910 charvalue,
8911 is_finite_list,
8912 is_vector,
8913 list_length,
8914 vector_len,
8915 fill_vector,
8916 vector_elem,
8917 set_vector_elem,
8918 is_port,
8919
8920 is_pair,
8921 pair_car,
8922 pair_cdr,
8923 set_car,
8924 set_cdr,
8925
8926 is_symbol,
8927 symname,
8928
8929 is_continuation,
8930 is_environment,
8931 is_immutable,
8932 setimmutable,
8933
8934 klink_load_file,
8935 klink_load_string,
8936 };
8937 #if USE_DL
8938 /* $$MOVE ME Later after I separate some headers
8939 This belongs in dynload.c, could be just:
8940 SIG_CHKARRAY(klink_load_ext) = { REF_OPER(is_string), };
8941 DEF_SIMPLE_APPLICATIVE(ps0a1,klink_load_ext,0,ground, "load-extension") {...}
8942 */
8943 RGSTR(ground, "load-extension", REF_APPL(klink_load_ext))
8944 SIG_CHKARRAY(klink_load_ext) = { REF_OPER(is_string), };
8945 DEF_SIMPLE_DESTR(klink_load_ext);
8946 DEF_CFUNC_PSYCNAME(ps0a1,klink_load_ext, REF_DESTR(klink_load_ext),0);
8947 DEF_BOXED_APPLICATIVE(klink_load_ext, REF_OPER (klink_load_ext));
8948
8949 #endif
8950
8951 #endif
8952
8953 /*_ . Initializing Klink */
8954 /*_ , Allocate and initialize */
8955
8956 klink *
8957 klink_alloc_init (FILE * in, FILE * out)
8958 {
8959 klink *sc = (klink *) GC_MALLOC (sizeof (klink));
8960 if (!klink_init (sc, in, out))
8961 {
8962 GC_FREE (sc);
8963 return 0;
8964 }
8965 else
8966 {
8967 return sc;
8968 }
8969 }
8970
8971 /*_ , Initialization without allocation */
8972 int
8973 klink_init (klink * sc, FILE * in, FILE * out)
8974 {
8975 /* Init stack first, just in case something calls _klink_error_1. */
8976 dump_stack_initialize (sc);
8977 /* Initialize ports early in case something prints. */
8978 /* $$IMPROVE ME Should accept general ports of appropriate in/out. */
8979 klink_set_input_port_file (sc, in);
8980 klink_set_output_port_file (sc, out);
8981
8982 #if USE_INTERFACE
8983 /* Why do we need this field if there is a static table? */
8984 sc->vptr = &vtbl;
8985 #endif
8986
8987 sc->tracing = 0;
8988 sc->new_tracing = 0;
8989
8990 if(!oblist)
8991 { oblist = oblist_initial_value (); }
8992
8993
8994 /* Add the Kernel built-ins */
8995 if(!print_lookup_env)
8996 {
8997 print_lookup_env = K_REGSTRS_TO_ENV(print_lookup_rgsts);
8998 }
8999 if(!all_builtins_env)
9000 {
9001 all_builtins_env = K_REGSTRS_TO_ENV(all_builtins);
9002 }
9003 if(!typecheck_env_syms)
9004 { typecheck_env_syms = K_REGSTRS_TO_ENV(typecheck_syms_rgsts); }
9005 if(!ground_env)
9006 {
9007 /** Register objects from hard-coded list. **/
9008 ground_env = K_REGSTRS_TO_ENV(preregister);
9009 /* $$TRANSITIONAL Set up special lookup tables related to preregister. */
9010 setup_print_secondary_lookup();
9011 /** Bind certain objects that we make at init time. **/
9012 kernel_define (ground_env,
9013 mk_symbol ("print-lookup-env"),
9014 print_lookup_env);
9015 kernel_define (unsafe_env,
9016 mk_symbol ("typecheck-special-syms"),
9017 typecheck_env_syms);
9018
9019 /** Read some definitions from a prolog **/
9020 /* We need an envir before klink_call, because that defines a
9021 few things. Those bindings are specific to one instance of
9022 the interpreter so they do not belong in anything shared such
9023 as ground_env. */
9024 /* $$IMPROVE ME Something in the call chain (klink_call?) should
9025 guarantee an environment. Needn't have anything in it to
9026 begin with. */
9027 sc->envir = make_new_frame(K_NIL);
9028
9029 /* Can't easily merge this with klink_load_named_file. Two
9030 difficulties: it uses klink_cycle_restarting while klink_call
9031 uses klink_cycle_no_restart, and here we need to control the
9032 load environment. */
9033 pko p = port_from_filename (InitFile, port_file | port_input);
9034 if (p == K_NIL) { return 0; }
9035
9036 /* We can't use k_get_mod_fm_port to manage parameters because
9037 later we will need the environment to have several parents:
9038 ground, simple, unsafe, possibly more. */
9039 /* Params: `into' = ground environment */
9040 /* We can't share this with the previous frame-making, because
9041 it should not define in the same environment. */
9042 pko params = make_new_frame(K_NIL);
9043 kernel_define (params, mk_symbol ("into"), ground_env);
9044 pko env = make_new_frame(ground_env);
9045 kernel_define (env, mk_symbol ("module-parameters"), params);
9046 int retcode = klink_call(sc,
9047 REF_OPER(load_from_port),
9048 LIST2(p, env));
9049 if(retcode) { return 0; }
9050
9051 /* The load will have written various things into ground
9052 environment. sc->envir is unsuitable now because it is this
9053 load's environment. */
9054 }
9055
9056 assert (is_environment (ground_env));
9057 sc->envir = make_new_frame(ground_env);
9058
9059 #if 1 /* Transitional. Leave this on for the moment */
9060 /* initialization of global pointers to special symbols */
9061 sc->QUOTE = mk_symbol ("quote");
9062 sc->QQUOTE = mk_symbol ("quasiquote");
9063 sc->UNQUOTE = mk_symbol ("unquote");
9064 sc->UNQUOTESP = mk_symbol ("unquote-splicing");
9065 sc->COLON_HOOK = mk_symbol ("*colon-hook*");
9066 sc->SHARP_HOOK = mk_symbol ("*sharp-hook*");
9067 #endif
9068 return 1;
9069 }
9070
9071 /*_ , Deinit */
9072 void
9073 klink_deinit (klink * sc)
9074 {
9075 sc->envir = K_NIL;
9076 sc->value = K_NIL;
9077 }
9078 /*_ . Using Klink from C */
9079 /*_ , To set ports */
9080 void
9081 klink_set_input_port_file (klink * sc, FILE * fin)
9082 {
9083 klink_push_dyn_binding(sc,K_INPORT,port_from_file (fin, port_input));
9084 }
9085
9086 void
9087 klink_set_input_port_string (klink * sc, char *start, char *past_the_end)
9088 {
9089 klink_push_dyn_binding(sc,
9090 K_INPORT,
9091 port_from_string (start, past_the_end, port_input));
9092 }
9093
9094 void
9095 klink_set_output_port_file (klink * sc, FILE * fout)
9096 {
9097 klink_push_dyn_binding(sc,K_OUTPORT,port_from_file (fout, port_output));
9098 }
9099
9100 void
9101 klink_set_output_port_string (klink * sc, char *start, char *past_the_end)
9102 {
9103 klink_push_dyn_binding(sc,
9104 K_OUTPORT,
9105 port_from_string (start, past_the_end, port_output));
9106 }
9107 /*_ , To set external data */
9108 void
9109 klink_set_external_data (klink * sc, void *p)
9110 {
9111 sc->ext_data = p;
9112 }
9113
9114
9115 /*_ , To load */
9116 /*_ . Load file (C) */
9117 /*_ , Worker */
9118 void
9119 klink_load_port (klink * sc, pko p, int interactive)
9120 {
9121 if (p == K_NIL)
9122 {
9123 sc->retcode = 2;
9124 return;
9125 }
9126 else
9127 {
9128 klink_push_dyn_binding(sc,K_INPORT,p);
9129 }
9130
9131 {
9132 pko combiner =
9133 interactive ?
9134 REF_OPER (kernel_repl) :
9135 REF_OPER (kernel_rel);
9136 klink_cycle_restarting (sc, combiner);
9137 }
9138 }
9139
9140 /*_ , klink_load_file */
9141 void
9142 klink_load_file (klink * sc, FILE * fin)
9143 {
9144 klink_load_port (sc,
9145 port_from_file (fin, port_file | port_input),
9146 (fin == stdin));
9147 }
9148
9149 /*_ , klink_load_named_file */
9150 void
9151 klink_load_named_file (klink * sc, FILE * fin, const char *filename)
9152 {
9153 klink_load_port(sc,
9154 port_from_filename (filename, port_file | port_input),
9155 (fin == stdin));
9156 }
9157
9158 /*_ . load string (C) */
9159
9160 void
9161 klink_load_string (klink * sc, const char *cmd)
9162 {
9163 klink_load_port(sc,
9164 port_from_string ((char *)cmd,
9165 (char *)cmd + strlen (cmd),
9166 port_input | port_string),
9167 0);
9168 }
9169
9170 /*_ , Apply combiner */
9171 /* sc is presumed to be already set up.
9172 The final value or error argument is in sc->value.
9173 The return code is duplicated in sc->retcode.
9174 */
9175 int
9176 klink_call (klink * sc, pko func, pko args)
9177 {
9178 klink_cycle_no_restart (sc,
9179 mk_curried(dcrry_NdotALL,args,func));
9180 return sc->retcode;
9181 }
9182
9183 /*_ , Eval form */
9184 /* This is completely unexercised. */
9185
9186 int
9187 klink_eval (klink * sc, pko obj)
9188 {
9189 klink_cycle_no_restart(sc,
9190 mk_curried(dcrry_2dotALL,
9191 LIST2(obj,sc->envir),
9192 REF_OPER(kernel_eval)));
9193 return sc->retcode;
9194 }
9195
9196 /*_ . Main (if standalone) */
9197 #if STANDALONE
9198 /*_ , Mac */
9199 #if defined(__APPLE__) && !defined (OSX)
9200 int
9201 main ()
9202 {
9203 extern MacTS_main (int argc, char **argv);
9204 char **argv;
9205 int argc = ccommand (&argv);
9206 MacTS_main (argc, argv);
9207 return 0;
9208 }
9209
9210 /*_ , General */
9211 int
9212 MacTS_main (int argc, char **argv)
9213 {
9214 #else
9215 int
9216 main (int argc, char **argv)
9217 {
9218 #endif
9219 klink sc;
9220 FILE *fin = 0;
9221 char *file_name = 0; /* Was InitFile */
9222 int retcode;
9223 int isfile = 1;
9224 GC_INIT ();
9225 if (argc == 1)
9226 {
9227 printf (banner);
9228 }
9229 if (argc == 2 && strcmp (argv[1], "-?") == 0)
9230 {
9231 printf ("Usage: klink -?\n");
9232 printf ("or: klink [<file1> <file2> ...]\n");
9233 printf ("followed by\n");
9234 printf (" -1 <file> [<arg1> <arg2> ...]\n");
9235 printf (" -c <Kernel commands> [<arg1> <arg2> ...]\n");
9236 printf ("assuming that the executable is named klink.\n");
9237 printf ("Use - as filename for stdin.\n");
9238 return 1;
9239 }
9240
9241 /* Make error_continuation semi-safe until it's properly set. */
9242 sc.error_continuation = 0;
9243 int i = setjmp (sc.pseudocontinuation);
9244 if (i == 0)
9245 {
9246 if (!klink_init (&sc, stdin, stdout))
9247 {
9248 fprintf (stderr, "Could not initialize!\n");
9249 return 2;
9250 }
9251 }
9252 else
9253 {
9254 fprintf (stderr, "Kernel error encountered while initializing!\n");
9255 return 3;
9256 }
9257 argv++;
9258 /* $$IMPROVE ME Maybe use get_opts instead. */
9259 while(1)
9260 {
9261 /* $$IMPROVE ME Add a principled way of sometimes including
9262 filename defined in environment. Eg getenv
9263 ("KLINKINIT"). */
9264 file_name = *argv;
9265 argv++;
9266 if(!file_name) { break; }
9267 if (strcmp (file_name, "-") == 0)
9268 {
9269 fin = stdin;
9270 }
9271 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
9272 {
9273 pko args = K_NIL;
9274 /* $$FACTOR ME This is a messy way to distinguish command
9275 string from filename string */
9276 isfile = (file_name[1] == '1');
9277 file_name = *argv++;
9278 if (strcmp (file_name, "-") == 0)
9279 {
9280 fin = stdin;
9281 }
9282 else if (isfile)
9283 {
9284 fin = fopen (file_name, "r");
9285 }
9286
9287 /* Put remaining command-line args into *args* in envir. */
9288 for (; *argv; argv++)
9289 {
9290 pko value = mk_string (*argv);
9291 args = mcons (value, args);
9292 }
9293 args = unsafe_v2reverse_in_place (K_NIL, args);
9294 /* Instead, use (command-line) as accessor and provide the
9295 whole command line as a list of strings. */
9296 kernel_define (sc.envir, mk_symbol ("*args*"), args);
9297
9298 }
9299 else
9300 {
9301 fin = fopen (file_name, "r");
9302 }
9303 if (isfile && fin == 0)
9304 {
9305 fprintf (stderr, "Could not open file %s\n", file_name);
9306 }
9307 else
9308 {
9309 if (isfile)
9310 {
9311 /* $$IMPROVE ME Use klink_load_named_file, replacing the
9312 file-opening code, so we can report filename */
9313 klink_load_file (&sc, fin);
9314 }
9315 else
9316 {
9317 klink_load_string (&sc, file_name);
9318 }
9319 if (!isfile || fin != stdin)
9320 {
9321 if (sc.retcode != 0)
9322 {
9323 fprintf (stderr, "Errors encountered reading %s\n",
9324 file_name);
9325 }
9326 if (isfile)
9327 {
9328 fclose (fin);
9329 }
9330 }
9331 }
9332 }
9333
9334 if (argc == 1)
9335 {
9336 /* $$MAKE ME CLEANER Quick and dirty for now, we make an
9337 environment for this but let everything else modify ground
9338 env. I'd like to be more correct about that. */
9339 /* Make an interactive environment over ground_env. */
9340 new_frame_in_env (&sc, sc.envir);
9341 klink_load_file (&sc, stdin);
9342 }
9343 retcode = sc.retcode;
9344 klink_deinit (&sc);
9345
9346 return retcode;
9347 }
9348
9349 #endif
9350
9351 /*_ , Footers */
9352 /*
9353 Local variables:
9354 c-file-style: "gnu"
9355 mode: allout
9356 End:
9357 */
Interpreter for the Kernel programming language