klink.c

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