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