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, pko provoker)
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                           provoker)),
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, pko provoker)
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                                  provoker);
2837                   /* If there's error, contribute to describing its
2838                      location. */
2839                   if (outcome == destr_err)
2840                     {
2841                       *extra_result =
2842                         LISTSTAR3(mk_integer(el_num),
2843                                   mk_symbol("dot"),
2844                                   *extra_result);
2845                     }
2846                   return outcome;
2847                 }
2848             }
2849           if(tych == REF_KEY(K_TYCH_OPTIONAL))
2850             {
2851               if(saw_optional)
2852                 {
2853                   KERNEL_ERROR_0 (sc, "destructure: Can't have two optionals");
2854                 }
2855               else
2856                 {
2857                   saw_optional = 1;
2858                   continue;
2859                 }
2860             }
2861           /*** Manage stepping ***/
2862           if(!is_pair(argobject))
2863             {
2864               if(saw_optional)
2865                 {
2866                   *outarray[0] = K_INERT;
2867                   ++*outarray;
2868                 }
2869               else
2870                 if (is_promise (argobject))
2871                   {
2872                     WITH_BOX_TYPE(tag,typespec);
2873                     pko new_typespec =
2874                       mk_foresliced_basvector (typespec,
2875                                                pdata->cvec.len - left,
2876                                                *tag);
2877                     *extra_result =
2878                       destructure_make_ops (argobject,
2879                                             new_typespec,
2880                                             saw_optional,
2881                                             provoker);
2882                     return destr_must_call_k;
2883                   }
2884               else
2885                 {
2886                   /* $$IMPROVE ME These symbols should be made
2887                      only once. */
2888                   /* $$IMPROVE ME These location operations should be
2889                      encapped. */
2890                   *extra_result =
2891                     LIST2(mk_integer(el_num), mk_symbol("too-few"));
2892                   return destr_err;
2893                 }
2894             }
2895           else
2896             {
2897               pko c = pair_car(0,argobject);
2898               argobject = pair_cdr(0,argobject);
2899               el_num++;
2900               int outcome =
2901                 destructure (sc,
2902                              c,
2903                              tych,
2904                              outarray,
2905                              past_end,
2906                              extra_result,
2907                              0,
2908                              provoker);
2909               switch (outcome)
2910                 {
2911                 case destr_success:
2912                   /* Success keeps exploring */
2913                   break;
2914                 case destr_err:
2915                   /* Simple error ends exploration */
2916                   /* Contribute to describing its location. */
2917                   *extra_result =
2918                     LISTSTAR2(mk_integer(el_num),*extra_result);
2919                   return destr_err;
2920                 case destr_must_call_k:
2921                   /* must-call-K schedules to resume in this state,
2922                      then returns. */
2923                   {
2924                     WITH_BOX_TYPE(tag,typespec);
2925                     /* $$IMPROVE ME If length = 0, this is just
2926                        REF_OPER (is_null) */
2927                     pko new_typespec =
2928                       mk_foresliced_basvector (typespec,
2929                                                pdata->cvec.len - left + 1,
2930                                                *tag);
2931                     pko raw_oplist = *extra_result;
2932                     *extra_result =
2933                       LISTSTAR4 (
2934                                  REF_OPER (destructure_resume),
2935                                  /* ^V= (result-so-far argobject spec
2936                                     optional?) */
2937                                  mk_load (LIST5 (mk_load_ix (0, 0),
2938                                                  argobject,
2939                                                  new_typespec,
2940                                                  kernel_bool (saw_optional),
2941                                                  K_NIL)),
2942                                  mk_store (K_ANY, 1),
2943                                  /* ^V= result-so-far */
2944                                  raw_oplist);
2945                     return destr_must_call_k;
2946                   }
2947                 default:
2948                   errx (7, "Unrecognized enumeration");
2949                 }
2950             }
2951         }
2952       if(argobject == K_NIL)
2953         { return destr_success; }
2954       else if (is_promise (argobject))
2955         {
2956           pko new_typespec = REF_OPER (is_null);
2957           *extra_result =
2958             destructure_make_ops (argobject,
2959                                   new_typespec,
2960                                   saw_optional,
2961                                   provoker);
2962           return destr_must_call_k;
2963         }
2964       else
2965         {
2966           *extra_result =
2967             LIST2(mk_integer(el_num), mk_symbol("too-many"));
2968           return destr_err;
2969         }
2970
2971     }
2972   else if (!no_call_k(typespec))
2973     {
2974       if (!is_combiner (typespec))
2975         {
2976           KERNEL_ERROR_0 (sc, "spec must be a combiner");
2977           /* NOTREACHED */
2978         }
2979
2980       *extra_result =
2981         destructure_make_ops_to_bool (argobject, typespec);
2982       return destr_must_call_k;
2983     }
2984   else if(typecheck(sc, argobject, typespec))
2985     {
2986       *outarray[0] = argobject;
2987       ++*outarray;
2988       return destr_success;
2989     }
2990   else if (is_promise (argobject))
2991     {
2992       *extra_result =
2993         destructure_make_ops (argobject,
2994                               typespec,
2995                               0,
2996                               provoker);
2997       return destr_must_call_k;
2998     }
2999   else
3000     {
3001       pko result = where_typemiss(sc, argobject, typespec);
3002       result = result ? result : mk_string("Couldn't find the typemiss");
3003       *extra_result = result;
3004       return destr_err;
3005     }
3006 }
3007 /*_     , destructure_to_array */
3008 void
3009 destructure_to_array
3010 (klink * sc,
3011  pko obj,                      /* Object to extract values from */
3012  pko type,                     /* Type spec */
3013  pko * array,                  /* Array to be filled */
3014  size_t length,                /* Maximum length of that array */
3015  pko resume_op,                /* Combiner to schedule if we resume */
3016  pko resume_data,       /* Extra data to the resume op */
3017  pko provoker           /* Provoker, in case of error */
3018  )
3019 {
3020   if (type == K_NO_TYPE)
3021     { return; }
3022   pko * orig_array = array;
3023   pko extra_result = 0;
3024   kt_destr_outcome outcome =
3025     destructure (sc,
3026                  obj,
3027                  type,
3028                  &array,
3029                  array + length,
3030                  &extra_result,
3031                  0,
3032                  provoker);
3033   switch (outcome)
3034     {
3035     case destr_success:
3036       return;
3037       /* NOTREACHED */
3038     case destr_err:
3039       {
3040         assert (extra_result);
3041         _klink_error_1 (sc, "type mismatch:",
3042                         LIST2 (provoker, extra_result));
3043         return;
3044       }
3045       /* NOTREACHED */
3046
3047     case destr_must_call_k:
3048       {
3049         /* Arrange for a resume. */
3050         int read_len = array - orig_array;
3051         pko result_so_far = mk_destr_result (read_len, orig_array, K_NIL);
3052         assert (is_combiner (resume_op));
3053         CONTIN_0_RAW (resume_op, sc);
3054         /* ^^^V= (final-destr_result . resume_data) */
3055         CONTIN_0_RAW (mk_load (LISTSTAR2 (mk_load_ix (0, 0),
3056                                           resume_data)),
3057                       sc);
3058         CONTIN_0_RAW (mk_store (K_ANY, 1), sc);
3059         /* ^^^V= final-destr_result */
3060         schedule_rv_list (sc, extra_result);
3061         /* ^^^V= current-destr_result */
3062         /* $$ENCAPSULATE ME */
3063         sc->value = result_so_far;
3064         longjmp (sc->pseudocontinuation, 1);
3065       /* NOTREACHED */
3066         return;
3067       }
3068       /* NOTREACHED */
3069
3070     default:
3071       errx (7, "Unrecognized enumeration");
3072     }
3073 }
3074
3075 /*_     , destructure_resume */
3076 SIG_CHKARRAY (destructure_resume) =
3077 {
3078   REF_OPER (is_destr_result),
3079   K_ANY,
3080   K_TY_DESTRSPEC,
3081   REF_OPER (is_bool),
3082   K_ANY,
3083 };
3084 DEF_SIMPLE_CFUNC (ps0a5, destructure_resume, 0)
3085 {
3086   WITH_5_ARGS (destr_result, argobject, typespec, opt_p, provoker);
3087   const int max_args = 5;
3088   pko arg_array [max_args];
3089   pko * outarray = arg_array;
3090   pko extra_result = 0;
3091   kt_destr_outcome outcome =
3092     destructure (sc,
3093                  argobject,
3094                  typespec,
3095                  &outarray,
3096                  arg_array + max_args,
3097                  &extra_result,
3098                  (opt_p == K_T),
3099                  provoker);
3100   switch (outcome)
3101     {
3102     case destr_success:
3103       {
3104         int new_len = outarray - arg_array;
3105         return
3106           mk_destr_result_add (destr_result, new_len, arg_array);
3107       }
3108       /* NOTREACHED */
3109     case destr_err:
3110       KERNEL_ERROR_1 (sc, "type mismatch:",
3111                       LIST2 (provoker, extra_result));
3112       /* NOTREACHED */
3113
3114     case destr_must_call_k:
3115       {
3116         /* Arrange for another force+resume. This will feed whatever
3117            was there before. */
3118         int read_len = outarray - arg_array;
3119         pko result_so_far =
3120           mk_destr_result_add (destr_result,
3121                                read_len,
3122                                arg_array);
3123         schedule_rv_list (sc, extra_result);
3124         return result_so_far;
3125       }
3126       /* NOTREACHED */
3127
3128     default:
3129       errx (7, "Unrecognized enumeration");
3130       /* NOTREACHED */
3131     }
3132 }
3133 /*_     , do-destructure */
3134 /* We don't have a typecheck typecheck predicate yet, so accept
3135    anything for arg2. Really it can be what typecheck accepts or
3136    T_DESTRUCTURE, checked recursively.  */
3137 SIG_CHKARRAY (do_destructure) = { K_ANY, K_ANY, };
3138 DEF_SIMPLE_APPLICATIVE (ps0a2, do_destructure,T_NO_K,unsafe,"do-destructure")
3139 {
3140   WITH_2_ARGS (argobject,typespec);
3141   int len = destructure_how_many (typespec);
3142   pko vec = mk_vector (len, K_NIL);
3143   WITH_UNBOXED_UNSAFE (pdata,kt_destr_list,vec);
3144   destructure_to_array
3145     (sc,
3146      argobject,
3147      typespec,
3148      pdata->cvec.els,
3149      len,
3150      REF_OPER (destr_result_to_vec),
3151      K_NIL,
3152      REF_OPER (do_destructure));
3153
3154   return vec;
3155 }
3156
3157 /*_   , C functions as objects */
3158 /*_    . Structs */
3159 /*_     , store */
3160 typedef struct kt_opstore
3161 {
3162   pko destr;                    /* Often a T_DESTRUCTURE */
3163   int frame_depth;
3164 } kt_opstore;
3165
3166 /*_    . cfunc */
3167 DEF_T_PRED (is_cfunc, T_CFUNC,no,"");
3168
3169 #if 0
3170 /* For external use, if some code ever wants to make these objects
3171    dynamically. */
3172 /* $$MAKE ME SAFE Set type-check fields */
3173 pko
3174 mk_cfunc (const kt_cfunc * f)
3175 {
3176   typedef kt_boxed_cfunc TT;
3177   errx(4, "Don't use mk_cfunc yet")
3178   TT *pbox = GC_MALLOC (sizeof (TT));
3179   pbox->type = T_CFUNC;
3180   pbox->data = *f;
3181   return PTR2PKO(pbox);
3182 }
3183 #endif
3184
3185 INLINE const kt_cfunc *
3186 get_cfunc_func (pko p)
3187 {
3188   WITH_PSYC_UNBOXED(kt_cfunc,p,T_CFUNC,0)
3189   return pdata;
3190 }
3191 /*_    . cfunc_resume */
3192 /*_     , Create */
3193 /*_      . mk_cfunc_resume */
3194 pko
3195 mk_cfunc_resume (pko cfunc)
3196 {
3197   ALLOC_BOX_PRESUME (kt_cfunc, T_CFUNC_RESUME);
3198   pbox->data = *get_cfunc_func (cfunc);
3199   return PTR2PKO(pbox);
3200 }
3201
3202 /*_    . Curried functions */
3203 /*_     , About objects */
3204 static INLINE int
3205 is_curried (pko p)
3206 { return is_type (p, T_CURRIED); }
3207
3208 INLINE pko
3209 mk_curried (decurrier_f decurrier, pko args, pko next)
3210 {
3211   ALLOC_BOX(pbox,T_CURRIED,kt_boxed_curried);
3212   pbox->data.decurrier = decurrier;
3213   pbox->data.args      = args;
3214   pbox->data.next      = next;
3215   pbox->data.argcheck  = 0;
3216   return PTR2PKO(pbox);
3217 }
3218 /*_     , Operations */
3219 /*_      . call_curried */
3220 pko
3221 call_curried(klink * sc, pko curried, pko value)
3222 {
3223   WITH_PSYC_UNBOXED(kt_curried,curried,T_CURRIED,sc);
3224
3225   /* First schedule the next one if there is any */
3226   if(pdata->next)
3227     {
3228       klink_push_cont(sc, pdata->next);
3229     }
3230
3231   /* Then call the decurrier with the data field and the value,
3232      returning its result. */
3233   return pdata->decurrier (sc, pdata->args, value);
3234 }
3235
3236 /*_    . Chains */
3237 /*_     , Struct */
3238 typedef kt_vector kt_chain;
3239
3240 /*_     , Creating */
3241 /*_      . Statically */
3242 #define SIG_CHAIN(C_NAME) pko CHAIN_NAME(C_NAME)[]
3243 #define DEF_CHAIN(NAME, ARRAY_NAME)                     \
3244   DEF_VEC(T_CHAIN | T_IMMUTABLE, NAME, ARRAY_NAME)
3245
3246 #define DEF_SIMPLE_CHAIN(C_NAME)                        \
3247   RGSTR(all-builtins,"C-" #C_NAME, REF_OPER (C_NAME))   \
3248   DEF_CHAIN(OPER(C_NAME), CHAIN_NAME(C_NAME))
3249
3250
3251 /*_     , Operations */
3252 void
3253 schedule_chain(klink * sc, const kt_vector * chain)
3254 {
3255   _kt_spagstack dump = sc->dump;
3256   int i;
3257   for(i = chain->len - 1; i >= 0; i--)
3258     {
3259       pko comb = chain->els[i];
3260       /* If frame_depth is unassigned, assign it. */
3261       if(_get_type(comb) == T_STORE)
3262         {
3263           WITH_UNBOXED_UNSAFE( pdata, kt_opstore, comb );
3264           if(pdata->frame_depth < 0)
3265             { pdata->frame_depth = chain->len - 1 - i; }
3266         }
3267       /* Push it as a combiner */
3268       dump = klink_push_cont_aux(dump, comb, sc->envir);
3269     }
3270   sc->dump = dump;
3271 }
3272
3273 /*_      . eval_chain */
3274 pko
3275 eval_chain( klink * sc, pko functor, pko value )
3276 {
3277   WITH_PSYC_UNBOXED( kt_vector, functor, T_CHAIN, 0 );
3278   schedule_chain( sc, pdata);
3279   return value;
3280 }
3281 /*_      . schedule_rv_list */
3282 void
3283 schedule_rv_list (klink * sc, pko list)
3284 {
3285   WITH_REPORTER (sc);
3286   _kt_spagstack dump = sc->dump;
3287   for(; list != K_NIL; list = cdr (list))
3288     {
3289       pko comb = car (list);
3290       /* $$PUNT If frame_depth is unassigned, assign it. */
3291
3292       /* Push it as a combiner */
3293       dump = klink_push_cont_aux(dump, comb, sc->envir);
3294     }
3295   sc->dump = dump;
3296 }
3297 /*_    . No-trace */
3298 /*_     , Create */
3299 inline static pko
3300 mk_notrace( pko combiner )
3301 {
3302   ALLOC_BOX_PRESUME( pko, T_NOTRACE );
3303   *pdata = combiner;
3304   return PTR2PKO(pbox);
3305 }
3306
3307 /*_     , Parts */
3308 inline static pko
3309 notrace_comb( pko p )
3310 {
3311   WITH_PSYC_UNBOXED( pko, p, T_NOTRACE, 0 );
3312   return *pdata;
3313 }
3314 /*_    . Store */
3315 /*_     , Create */
3316 /*_      . statically */
3317 #define STORE_DEF(DATA)                         \
3318   { T_STORE | T_IMMUTABLE, { DATA, -1, }, }
3319
3320 #define ANON_STORE(DATA)                        \
3321   ANON_REF (kt_opstore, STORE_DEF(DATA))
3322
3323 /*_      . dynamically */
3324 pko
3325 mk_store (pko data, int depth)
3326 {
3327   ALLOC_BOX_PRESUME(kt_opstore, T_STORE | T_IMMUTABLE);
3328   pdata->destr       = data;
3329   pdata->frame_depth = depth;
3330   return PTR2PKO(pbox);
3331 }
3332
3333 /*_    . Load */
3334 /*_     , Struct */
3335 typedef pko kt_opload;
3336
3337 /*_     , Create */
3338 /*_      . statically */
3339 #define LOAD_DEF( DATA )                        \
3340   { T_LOAD | T_IMMUTABLE, DATA, }
3341
3342 #define ANON_LOAD( DATA )                       \
3343   ANON_REF( pko, LOAD_DEF( DATA ))
3344
3345 #define ANON_LOAD_IX( X, Y )             \
3346   ANON_PAIR(ANON_REF(num, INT_DEF( X )), \
3347             ANON_REF(num, INT_DEF( Y )))
3348 /*_      . dynamically */
3349 /*_       , mk_load_ix */
3350 pko
3351 mk_load_ix (int x, int y)
3352 {
3353   return cons (mk_integer (x), mk_integer (y));
3354 }
3355 /*_       , mk_load */
3356 pko
3357 mk_load (pko data)
3358 {
3359   ALLOC_BOX_PRESUME(kt_opload, T_LOAD | T_IMMUTABLE);
3360   *pdata = data;
3361   return PTR2PKO(pbox);
3362 }
3363
3364 /*_   , pairs proper */
3365 /*_    . Type */
3366 DEF_T_PRED (is_pair, T_PAIR,ground, "pair?/o1");
3367
3368 /*_    . Create */
3369 SIG_CHKARRAY(Xcons) = { K_ANY, K_ANY, };
3370 DEF_SIMPLE_DESTR(Xcons);
3371 DEF_APPLICATIVE_W_DESTR(p00a2,mk_pair, REF_DESTR(Xcons),T_NO_K,ground, "cons")
3372 {
3373   WITH_2_ARGS(a,b);
3374   return cons (a, b);
3375 }
3376
3377 DEF_APPLICATIVE_W_DESTR(p00a2,mk_mutable_pair, REF_DESTR(Xcons),T_NO_K,ground, "mcons")
3378 {
3379   WITH_2_ARGS(a,b);
3380   return mcons (a, b);
3381 }
3382
3383 /*_    . Parts and operations */
3384
3385 SIG_CHKARRAY(pair_cxr) = { REF_OPER(is_pair), };
3386 DEF_SIMPLE_DESTR(pair_cxr);
3387 DEF_APPLICATIVE_W_DESTR(ps0a1,pair_car, REF_DESTR(pair_cxr),T_NO_K,ground, "car")
3388 {
3389   WITH_1_ARGS(p);
3390   return v2car(sc,T_PAIR,p);
3391 }
3392
3393 DEF_APPLICATIVE_W_DESTR(ps0a1,pair_cdr, REF_DESTR(pair_cxr),T_NO_K,ground, "cdr")
3394 {
3395   WITH_1_ARGS(p);
3396   return v2cdr(sc,T_PAIR,p);
3397 }
3398
3399 SIG_CHKARRAY(pair_set_cxr) = { REF_OPER(is_pair),  K_ANY, };
3400 DEF_SIMPLE_DESTR(pair_set_cxr);
3401 DEF_APPLICATIVE_W_DESTR(ps0a2,set_car, REF_DESTR(pair_set_cxr),T_NO_K,ground, "set-car!")
3402 {
3403   WITH_2_ARGS(p,q);
3404   v2set_car(sc,T_PAIR,p,q);
3405   return K_INERT;
3406 }
3407
3408 DEF_APPLICATIVE_W_DESTR(ps0a2,set_cdr, REF_DESTR(pair_set_cxr),T_NO_K,ground, "set-cdr!")
3409 {
3410   WITH_2_ARGS(p,q);
3411   v2set_cdr(sc,T_PAIR,p,q);
3412   return K_INERT;
3413 }
3414 /*_     , Normal (one arg) */
3415 /*_     , Values as pairs */
3416 DEF_CFUNC_RAW(OPER (valcar), ps0a1, pair_car, REF_OPER (is_pair), T_NO_K);
3417 DEF_CFUNC_RAW(OPER (valcdr), ps0a1, pair_cdr, REF_OPER (is_pair), T_NO_K);
3418
3419 /*_   , Strings */
3420 /*_    . Type */
3421 DEF_T_PRED (is_string, T_STRING,ground,"string?/o1");
3422 /*_    . Create */
3423
3424 INTERFACE INLINE pko
3425 mk_string (const char *str)
3426 {
3427   return mk_bastring (T_STRING, str, strlen (str), 0);
3428 }
3429
3430 INTERFACE INLINE pko
3431 mk_counted_string (const char *str, int len)
3432 {
3433   return mk_bastring (T_STRING, str, len, 0);
3434 }
3435
3436 INTERFACE INLINE pko
3437 mk_empty_string (int len, char fill)
3438 {
3439   return mk_bastring (T_STRING, 0, len, fill);
3440 }
3441 /*_    . Create static */
3442 /* $$WRITE ME  As for k_print_terminate_list macros */
3443
3444 /*_    . Accessors */
3445 INTERFACE INLINE char *
3446 string_value (pko p)
3447 {
3448   return bastring_value(0,T_STRING,p);
3449 }
3450
3451 INTERFACE INLINE int
3452 string_len (pko p)
3453 {
3454   return bastring_len(0,T_STRING,p);
3455 }
3456
3457 /*_   , Symbols */
3458 /*_    . Type */
3459 DEF_T_PRED(is_symbol, T_SYMBOL,ground,"symbol?/o1");
3460 /*_    . Create */
3461 static pko
3462 mk_symbol_obj (const char *name)
3463 {
3464   return mk_bastring (T_SYMBOL | T_IMMUTABLE, name, strlen (name), 0);
3465 }
3466
3467 /* We want symbol objects to be unique per name, so check an oblist of
3468    unique symbols. */
3469 INTERFACE pko
3470 mk_symbol (const char *name)
3471 {
3472   /* first check oblist */
3473   pko x = oblist_find_by_name (name);
3474   if (x != K_NIL)
3475     {
3476       return x;
3477     }
3478   else
3479     {
3480       x = oblist_add_by_name (name);
3481       return x;
3482     }
3483 }
3484 /*_    . oblist implementation */
3485 /*_     , Global object */
3486 static pko oblist = 0;
3487 /*_     , Oblist as hash table */
3488 #ifndef USE_OBJECT_LIST
3489
3490 static int hash_fn (const char *key, int table_size);
3491
3492 static pko
3493 oblist_initial_value ()
3494 {
3495   return mk_vector (461, K_NIL);
3496 }
3497
3498 /* returns the new symbol */
3499 static pko
3500 oblist_add_by_name (const char *name)
3501 {
3502   pko x = mk_symbol_obj (name);
3503   int location = hash_fn (name, vector_len (oblist));
3504   set_vector_elem (oblist, location,
3505                    cons (x, vector_elem (oblist, location)));
3506   return x;
3507 }
3508
3509 static INLINE pko
3510 oblist_find_by_name (const char *name)
3511 {
3512   int location;
3513   pko x;
3514   char *s;
3515   WITH_REPORTER(0);
3516
3517   location = hash_fn (name, vector_len (oblist));
3518   for (x = vector_elem (oblist, location); x != K_NIL; x = cdr (x))
3519     {
3520       s = symname (0,car (x));
3521       /* case-insensitive, per R5RS section 2. */
3522       if (stricmp (name, s) == 0)
3523         {
3524           return car (x);
3525         }
3526     }
3527   return K_NIL;
3528 }
3529
3530 static pko
3531 oblist_all_symbols (void)
3532 {
3533   int i;
3534   pko x;
3535   pko ob_list = K_NIL;
3536
3537   for (i = 0; i < vector_len (oblist); i++)
3538     {
3539       for (x = vector_elem (oblist, i); x != K_NIL; x = cdr (x))
3540         {
3541           ob_list = mcons (x, ob_list);
3542         }
3543     }
3544   return ob_list;
3545 }
3546
3547 /*_     , Oblist as list */
3548 #else
3549
3550 static pko
3551 oblist_initial_value ()
3552 {
3553   return K_NIL;
3554 }
3555
3556 static INLINE pko
3557 oblist_find_by_name (const char *name)
3558 {
3559   pko x;
3560   char *s;
3561   WITH_REPORTER(0);
3562   for (x = oblist; x != K_NIL; x = cdr (x))
3563     {
3564       s = symname (0,car (x));
3565       /* case-insensitive, per R5RS section 2. */
3566       if (stricmp (name, s) == 0)
3567         {
3568           return car (x);
3569         }
3570     }
3571   return K_NIL;
3572 }
3573
3574 /* returns the new symbol */
3575 static pko
3576 oblist_add_by_name (const char *name)
3577 {
3578   pko x = mk_symbol_obj (name);
3579   oblist = cons (x, oblist);
3580   return x;
3581 }
3582
3583 static pko
3584 oblist_all_symbols (void)
3585 {
3586   return oblist;
3587 }
3588
3589 #endif
3590
3591
3592 /*_    . Parts and operations */
3593 SIG_CHKARRAY(string_to_symbol) = { REF_OPER(is_string), };
3594 DEF_SIMPLE_APPLICATIVE(ps0a1,string_to_symbol,T_NO_K,ground, "string->symbol")
3595 {
3596   return mk_symbol(string_value(arg1));
3597 }
3598
3599 INTERFACE INLINE char *
3600 symname (sc_or_null sc, pko p)
3601 {
3602   return bastring_value (sc,T_SYMBOL, p);
3603 }
3604
3605
3606 /*_   , Vectors */
3607
3608 /*_    . Type */
3609 DEF_T_PRED (is_vector, T_VECTOR,unsafe,"vector?/o1");
3610
3611 /*_    . Create */
3612 /*_     , mk_vector (T_ level) */
3613 INTERFACE static pko
3614 mk_vector (int len, pko fill)
3615 { return mk_filled_basvector(len, fill, T_VECTOR); }
3616
3617 /*_     , k_mk_vector (K level) */
3618 /* $$RETHINK ME  This may not be wanted. */
3619 SIG_CHKARRAY(k_mk_vector) = { REF_OPER(is_integer), REF_KEY(K_TYCH_OPTIONAL), K_ANY, };
3620 DEF_SIMPLE_APPLICATIVE (ps0a2, k_mk_vector,T_NO_K,unsafe,"make-vector")
3621 {
3622   WITH_2_ARGS(k_len, fill);
3623
3624   int len = ivalue (k_len);
3625   if (fill == K_INERT)
3626     { fill = K_NIL; }
3627   return mk_vector (len, fill);
3628 }
3629
3630 /*_     , vector */
3631 /* K_ANY instead of REF_OPER(is_finite_list) because
3632    mk_basvector_w_args checks list-ness internally */
3633 DEF_APPLICATIVE_W_DESTR(ps0a1, vector, K_ANY,T_NO_K,unsafe,"vector")
3634 {
3635   WITH_1_ARGS(p);
3636   return mk_basvector_w_args(sc,p,T_VECTOR);
3637 }
3638
3639 /*_    . Operations (T_ level) */
3640 /*_     , fill_vector */
3641
3642 INTERFACE static void
3643 fill_vector (pko vec, pko obj)
3644 {
3645   assert(_get_type(vec) == T_VECTOR);
3646   unsafe_basvector_fill(vec,obj);
3647 }
3648
3649 /*_    . Parts of vectors (T_ level) */
3650
3651 INTERFACE static int
3652 vector_len (pko vec)
3653 {
3654   assert(_get_type(vec) == T_VECTOR);
3655   return basvector_len(vec);
3656 }
3657
3658 INTERFACE static pko
3659 vector_elem (pko vec, int ielem)
3660 {
3661   assert(_get_type(vec) == T_VECTOR);
3662   return basvector_elem(vec, ielem);
3663 }
3664
3665 INTERFACE static void
3666 set_vector_elem (pko vec, int ielem, pko a)
3667 {
3668   assert(_get_type(vec) == T_VECTOR);
3669   basvector_set_elem(vec, ielem, a);
3670   return;
3671 }
3672
3673 /*_   , Promises */
3674 /* T_PROMISE is essentially a handle, pointing to a pair of either
3675    (expression env) or (value #f).  We use #f, not nil, because nil is
3676    a possible environment. */
3677
3678 /*_    . Create */
3679 /*_     , $lazy */
3680 RGSTR(ground,"$lazy", REF_OPER(mk_promise_lazy))
3681 DEF_CFUNC(ps0a1, mk_promise_lazy, K_ANY_SINGLETON, T_NO_K)
3682 {
3683   WITH_1_ARGS(p);
3684   pko guts = mcons(p, mcons(sc->envir, mk_continuation(sc->dump)));
3685   return v2cons (T_PROMISE, guts, K_NIL);
3686 }
3687 /*_     , memoize */
3688 /* $$CHECK ME Is K_ANY correct?  Or K_ANY_SINGLETON?  */
3689 DEF_APPLICATIVE_W_DESTR(p00a1,mk_promise_memo,K_ANY,T_NO_K,ground,"memoize")
3690 {
3691   WITH_1_ARGS(p);
3692   pko guts = mcons(p, K_F);
3693   return v2cons (T_PROMISE, guts, K_NIL);
3694 }
3695 /*_    . Type */
3696
3697 DEF_T_PRED (is_promise,T_PROMISE,ground,"promise?/o1");
3698 /*_    . Helpers */
3699 /*_     , promise_schedule_eval */
3700 inline pko
3701 promise_schedule_eval(klink * sc, pko p)
3702 {
3703   WITH_REPORTER(sc);
3704   pko guts = unsafe_v2car(p);
3705   pko env     = car(cdr(guts));
3706   pko dynxtnt = cdr(cdr(guts));
3707   /* Arrange to eval the expression and pass the result to
3708      handle_promise_result */
3709   CONTIN_1R(dcrry_2ALLVLL,handle_promise_result,sc,p);
3710   /* $$ENCAP ME  This deals with continuation guts, so should be
3711      encapped.  As a special continuation-maker? */
3712   _kt_spagstack new_dump =
3713     special_dynxtnt (cont_dump(dynxtnt), sc->dump, env);
3714   sc->dump = new_dump;
3715   CONTIN_2(dcrry_2dotALL, kernel_eval, sc, car(guts), env);
3716   return K_INERT;
3717 }
3718 /*_     , handle_promise_result */
3719 SIG_CHKARRAY(handle_promise_result) = { REF_OPER(is_promise), K_ANY };
3720 DEF_SIMPLE_CFUNC(ps0a2,handle_promise_result,0)
3721 {
3722   /* guts are only made by C code so if they're wrong it's a C
3723      error */
3724   WITH_REPORTER(0);
3725   WITH_2_ARGS(p,value);
3726   pko guts = unsafe_v2car(p);
3727
3728   /* if p already has a result, return it */
3729   if(cdr(guts) == K_F)
3730     { return car(guts); }
3731   /* If value is again a promise, set this promise's guts to that
3732      promise's guts and force it again, which will force both (This is
3733      why we need promises to be 2-layer) */
3734   else if(is_promise(value))
3735     {
3736       unsafe_v2set_car (p, unsafe_v2car(value));
3737       return promise_schedule_eval(sc, p);
3738     }
3739   /* Otherwise set the value and return it. */
3740   else
3741     {
3742       unsafe_v2set_car (guts, value);
3743       unsafe_v2set_cdr (guts, K_F);
3744       return value;
3745     }
3746 }
3747 /*_    . Operations */
3748 /*_     , force */
3749 DEF_APPLICATIVE_W_DESTR (ps0a1, force, K_ANY_SINGLETON,T_NO_K,ground,"force")
3750 {
3751   /* guts are only made by this C code here, so if they're wrong it's
3752      a C error */
3753   WITH_REPORTER(0);
3754   WITH_1_ARGS(p);
3755   if(!is_promise(p))
3756     { return p; }
3757
3758   pko guts = unsafe_v2car(p);
3759   if(cdr(guts) == K_F)
3760     { return car(guts); }
3761   else
3762     { return promise_schedule_eval(sc,p); }
3763 }
3764
3765 /*_   , Ports */
3766 /*_    . Creating */
3767
3768 /* $$IMPROVE ME Just directly contain the port structure.  Possibly
3769    split port into several T_ types.  */
3770 static pko
3771 mk_port (port * pt)
3772 {
3773   ALLOC_BOX_PRESUME (port *, T_PORT);
3774   pbox->data = pt;
3775   return PTR2PKO(pbox);
3776 }
3777
3778 static port *
3779 port_rep_from_filename (const char *fn, int prop)
3780 {
3781   FILE *f;
3782   char *rw;
3783   port *pt;
3784   if (prop == (port_input | port_output))
3785     {
3786       rw = "a+";
3787     }
3788   else if (prop == port_output)
3789     {
3790       rw = "w";
3791     }
3792   else
3793     {
3794       rw = "r";
3795     }
3796   f = fopen (fn, rw);
3797   if (f == 0)
3798     {
3799       return 0;
3800     }
3801   pt = port_rep_from_file (f, prop);
3802   pt->rep.stdio.closeit = 1;
3803
3804 #if SHOW_ERROR_LINE
3805   if (fn)
3806     { pt->rep.stdio.filename = store_string (strlen (fn), fn, 0); }
3807
3808   pt->rep.stdio.curr_line = 0;
3809 #endif
3810   return pt;
3811 }
3812
3813 static pko
3814 port_from_filename (const char *fn, int prop)
3815 {
3816   port *pt;
3817   pt = port_rep_from_filename (fn, prop);
3818   if (pt == 0)
3819     {
3820       return K_NIL;
3821     }
3822   return mk_port (pt);
3823 }
3824
3825 static port *
3826 port_rep_from_file (FILE * f, int prop)
3827 {
3828   port *pt;
3829   pt = (port *) GC_MALLOC_ATOMIC (sizeof *pt);
3830   if (pt == NULL)
3831     {
3832       return NULL;
3833     }
3834   /* Don't care what goes in these but GC really wants to provide it
3835      so here are dummy objects to put it in. */
3836   GC_finalization_proc ofn;
3837   GC_PTR               ocd;
3838   GC_register_finalizer(pt, port_finalize_file, 0, &ofn, &ocd);
3839   pt->kind = port_file | prop;
3840   pt->rep.stdio.file = f;
3841   pt->rep.stdio.closeit = 0;
3842   return pt;
3843 }
3844
3845 static pko
3846 port_from_file (FILE * f, int prop)
3847 {
3848   port *pt;
3849   pt = port_rep_from_file (f, prop);
3850   if (pt == 0)
3851     {
3852       return K_NIL;
3853     }
3854   return mk_port (pt);
3855 }
3856
3857 static port *
3858 port_rep_from_string (char *start, char *past_the_end, int prop)
3859 {
3860   port *pt;
3861   pt = (port *) GC_MALLOC_ATOMIC (sizeof (port));
3862   if (pt == 0)
3863     {
3864       return 0;
3865     }
3866   pt->kind = port_string | prop;
3867   pt->rep.string.start = start;
3868   pt->rep.string.curr = start;
3869   pt->rep.string.past_the_end = past_the_end;
3870   return pt;
3871 }
3872
3873 static pko
3874 port_from_string (char *start, char *past_the_end, int prop)
3875 {
3876   port *pt;
3877   pt = port_rep_from_string (start, past_the_end, prop);
3878   if (pt == 0)
3879     {
3880       return K_NIL;
3881     }
3882   return mk_port (pt);
3883 }
3884
3885 #define BLOCK_SIZE 256
3886
3887 static int
3888 realloc_port_string (port * p)
3889 {
3890   /* $$IMPROVE ME  Just use REALLOC. */
3891   char *start = p->rep.string.start;
3892   size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
3893   char *str = GC_MALLOC_ATOMIC (new_size);
3894   if (str)
3895     {
3896       memset (str, ' ', new_size - 1);
3897       str[new_size - 1] = '\0';
3898       strcpy (str, start);
3899       p->rep.string.start = str;
3900       p->rep.string.past_the_end = str + new_size - 1;
3901       p->rep.string.curr -= start - str;
3902       return 1;
3903     }
3904   else
3905     {
3906       return 0;
3907     }
3908 }
3909
3910
3911 static port *
3912 port_rep_from_scratch (void)
3913 {
3914   port *pt;
3915   char *start;
3916   pt = (port *) GC_MALLOC_ATOMIC (sizeof (port));
3917   if (pt == 0)
3918     {
3919       return 0;
3920     }
3921   start = GC_MALLOC_ATOMIC (BLOCK_SIZE);
3922   if (start == 0)
3923     {
3924       return 0;
3925     }
3926   memset (start, ' ', BLOCK_SIZE - 1);
3927   start[BLOCK_SIZE - 1] = '\0';
3928   pt->kind = port_string | port_output | port_srfi6;
3929   pt->rep.string.start = start;
3930   pt->rep.string.curr = start;
3931   pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
3932   return pt;
3933 }
3934
3935 static pko
3936 port_from_scratch (void)
3937 {
3938   port *pt;
3939   pt = port_rep_from_scratch ();
3940   if (pt == 0)
3941     {
3942       return K_NIL;
3943     }
3944   return mk_port (pt);
3945 }
3946 /*_     , Interface */
3947 /*_      . open-input-file */
3948 SIG_CHKARRAY(k_open_input_file) =
3949   { REF_OPER(is_string), };
3950 DEF_SIMPLE_APPLICATIVE(ps0a1,k_open_input_file,0,ground, "open-input-file")
3951 {
3952   WITH_1_ARGS(filename);
3953   return port_from_filename (string_value(filename), port_file | port_input);
3954 }
3955
3956
3957 /*_    . Testing */
3958
3959 DEF_T_PRED (is_port, T_PORT,ground,"port?/o1");
3960
3961 DEF_SIMPLE_PRED (is_inport,T_NO_K,ground,"input-port?/o1")
3962 {
3963   WITH_1_ARGS(p);
3964   return is_port (p) && portvalue (p)->kind & port_input;
3965 }
3966
3967 DEF_SIMPLE_PRED (is_outport,T_NO_K,ground,"output-port?/o1")
3968 {
3969   WITH_1_ARGS(p);
3970   return is_port (p) && portvalue (p)->kind & port_output;
3971 }
3972
3973 /*_    . Values */
3974 INLINE port *
3975 portvalue (pko p)
3976 {
3977   WITH_PSYC_UNBOXED(port *,p,T_PORT,0);
3978   return *pdata;
3979 }
3980
3981 INLINE void
3982 set_portvalue (pko p, port * newport)
3983 {
3984   assert_mutable(0,p);
3985   WITH_PSYC_UNBOXED(port *,p,T_PORT,0);
3986   *pdata = newport;
3987   return;
3988 }
3989
3990 /*_    . reading from ports */
3991 static int
3992 inchar (port *pt)
3993 {
3994   int c;
3995
3996   if (pt->kind & port_saw_EOF)
3997     { return EOF; }
3998   c = basic_inchar (pt);
3999   if (c == EOF)
4000     { pt->kind |= port_saw_EOF; }
4001 #if SHOW_ERROR_LINE
4002   else if (c == '\n')
4003     {
4004       if (pt->kind & port_file)
4005         { pt->rep.stdio.curr_line++; }
4006     }
4007 #endif
4008
4009   return c;
4010 }
4011
4012 static int
4013 basic_inchar (port * pt)
4014 {
4015   if (pt->kind & port_file)
4016     {
4017       return fgetc (pt->rep.stdio.file);
4018     }
4019   else
4020     {
4021       if (*pt->rep.string.curr == 0 ||
4022           pt->rep.string.curr == pt->rep.string.past_the_end)
4023         {
4024           return EOF;
4025         }
4026       else
4027         {
4028           return *pt->rep.string.curr++;
4029         }
4030     }
4031 }
4032
4033 /* back character to input buffer */
4034 static void
4035 backchar (port * pt, int c)
4036 {
4037   if (c == EOF)
4038     { return; }
4039
4040   if (pt->kind & port_file)
4041     {
4042       ungetc (c, pt->rep.stdio.file);
4043 #if SHOW_ERROR_LINE
4044       if (c == '\n')
4045         {
4046           pt->rep.stdio.curr_line--;
4047         }
4048 #endif
4049     }
4050   else
4051     {
4052       if (pt->rep.string.curr != pt->rep.string.start)
4053         {
4054           --pt->rep.string.curr;
4055         }
4056     }
4057 }
4058
4059 /*_     , Interface */
4060
4061 /*_      . (get-char textual-input-port) */
4062 SIG_CHKARRAY(get_char) = { REF_OPER(is_inport), };
4063 DEF_SIMPLE_APPLICATIVE(p00a1,get_char,T_NO_K,ground, "get-char")
4064 {
4065   WITH_1_ARGS(port);
4066   assert(is_inport(port));
4067   int c = inchar(portvalue(port));
4068   if(c == EOF)
4069     { return K_EOF; }
4070   else
4071     { return mk_character(c); }
4072 }
4073
4074 /*_    . Finalization */
4075 static void
4076 port_finalize_file(GC_PTR obj, GC_PTR client_data)
4077 {
4078   port *pt = obj;
4079   if ((pt->kind & port_file) && pt->rep.stdio.closeit)
4080     { port_close_port (pt, port_input | port_output); }
4081 }
4082
4083 static void
4084 port_close (pko p, int flag)
4085 {
4086   assert(is_port(p));
4087   port_close_port(portvalue (p), flag);
4088 }
4089
4090 static void
4091 port_close_port (port * pt, int flag)
4092 {
4093   pt->kind &= ~flag;
4094   if ((pt->kind & (port_input | port_output)) == 0)
4095     {
4096       if (pt->kind & port_file)
4097         {
4098 #if SHOW_ERROR_LINE
4099           /* Cleanup is here so (close-*-port) functions could work too */
4100           pt->rep.stdio.curr_line = 0;
4101
4102 #endif
4103
4104           fclose (pt->rep.stdio.file);
4105         }
4106       pt->kind = port_free;
4107     }
4108 }
4109
4110
4111 /*_   , Encapsulation type */
4112
4113 SIG_CHKARRAY(is_encap) = { REF_OPER(is_key), K_ANY };
4114 DEF_SIMPLE_CFUNC(b00a2, is_encap,T_NO_K)
4115 {
4116   WITH_2_ARGS(type, p);
4117   if (is_type (p, T_ENCAP))
4118     {
4119       WITH_UNBOXED_UNSAFE(pdata,kt_encap,p);
4120       return (pdata->type == type);
4121     }
4122   else
4123     {
4124       return 0;
4125     }
4126 }
4127
4128 /* NOT directly part of the interface. */
4129 SIG_CHKARRAY(unencap) = { REF_OPER(is_key),  K_ANY};
4130 DEF_SIMPLE_CFUNC(ps0a2, unencap,T_NO_K)
4131 {
4132   WITH_2_ARGS(type, p);
4133   if (is_encap (type, p))
4134     {
4135       WITH_UNBOXED_UNSAFE(pdata,kt_encap,p);
4136       return pdata->value;
4137     }
4138   else
4139     {
4140       /* We have no type-name to give to the error message. */
4141       KERNEL_ERROR_0 (sc, "unencap: wrong type");
4142     }
4143 }
4144
4145 /* NOT directly part of the interface. */
4146 SIG_CHKARRAY(mk_encap) = { REF_OPER(is_key),  K_ANY};
4147 DEF_SIMPLE_CFUNC(p00a2, mk_encap,T_NO_K)
4148 {
4149   WITH_2_ARGS(type, value);
4150   ALLOC_BOX_PRESUME (kt_encap, T_ENCAP);
4151   pbox->data.type = type;
4152   pbox->data.value = value;
4153   return PTR2PKO(pbox);
4154 }
4155
4156 DEF_APPLICATIVE_W_DESTR (p00a0, mk_encapsulation_type, K_NO_TYPE,T_NO_K,ground, "make-encapsulation-type/raw")
4157 {
4158   /* A unique cell representing a type */
4159   pko type = mk_void();
4160   /* $$IMPROVE ME make typespecs for the curried objs.  trivpred is
4161      effectively that spec object.  */
4162   pko e   = wrap (mk_curried (dcrry_2ALLV01, type, REF_OPER (mk_encap)));
4163   pko trivpred = mk_curried (dcrry_2ALLV01, type, REF_OPER (is_encap));
4164   pko d   = wrap (mk_curried (dcrry_2ALLV01, type, REF_OPER (unencap)));
4165   return LIST3 (e, trivpred, d);
4166 }
4167 /*_   , Listloop types */
4168 /*_    . Forward declarations */
4169 struct kt_listloop;
4170 /*_    . Enumerations */
4171 /*_     , Next-style */
4172 /* How to turn the current list into current value and next list. */
4173 typedef enum
4174 {
4175   lls_1list,
4176   lls_many,
4177   lls_neighbors,
4178   lls_max,
4179 } kt_loopstyle_step;
4180 typedef enum
4181 {
4182   lls_combiner,
4183   lls_count,
4184   lls_top_count,
4185   lls_stop_on,
4186   lls_num_args,
4187 } kt_loopstyle_argix;
4188
4189 /*_    . Function signatures. */
4190 typedef pko (* kt_listloop_mk_val)(pko value,  struct kt_listloop * pll);
4191 /*_    . Struct */
4192 typedef struct kt_listloop_style
4193 {
4194   pko                combiner;  /* Default combiner or NULL. */
4195   int                collect_p; /* Whether to collect a (reversed)
4196                                    list of the returns. */
4197   kt_loopstyle_step  step;
4198   kt_listloop_mk_val mk_val; /* From returned value+state -> passed value. */
4199   pko                destructurer; /* A destructurer contents */
4200   /* Selection of args.  Each entry correspond to one arg in "full
4201      args", and indexes something in the array of actual args that the
4202      destructurer retrieves. */
4203   int                arg_select[lls_num_args];
4204 } kt_listloop_style;
4205 typedef struct kt_listloop
4206 {
4207   pko combiner;                 /* The combiner to use repeatedly. */
4208   pko list;                     /* The list to loop over */
4209   int top_length;               /* Length of top element, for lls_many. */
4210   int countdown;                /* Num elements left, or negative if unused. */
4211   int countup;                  /* Upwards count from 0. */
4212   pko stop_on;                  /* Stop if return value is this. Can
4213                                    be 0 for unused. */
4214   kt_listloop_style * style;    /* Non-NULL pointer to style. */
4215 } kt_listloop;
4216 /*_     , Internal signatures */
4217 pko
4218 listloop_aux (klink * sc,
4219               kt_listloop_style * style_v,
4220               pko list,
4221               pko style_args[lls_num_args]);
4222 FORWARD_DECL_CFUNC (static, ps0a3, listloop_resume);
4223
4224 /*_    . Creating */
4225 /*_     , Listloop styles */
4226 /* Unused */
4227 pko
4228 mk_listloop_style
4229 (pko combiner,
4230  int collect_p,
4231  kt_loopstyle_step step,
4232  kt_listloop_mk_val mk_val)
4233 {
4234   ALLOC_BOX_PRESUME(kt_listloop_style,T_LISTLOOP_STYLE);
4235   pdata->combiner   = combiner;
4236   pdata->collect_p  = collect_p;
4237   pdata->step       = step;
4238   pdata->mk_val     = mk_val;
4239   return PTR2PKO(pbox);
4240 }
4241 /*_     , Listloops */
4242 pko
4243 mk_listloop
4244 (pko combiner,
4245  pko list,
4246  int top_length,
4247  int count,
4248  pko stop_on,
4249  kt_listloop_style * style)
4250 {
4251   ALLOC_BOX_PRESUME(kt_listloop,T_LISTLOOP);
4252   pdata->combiner   = combiner;
4253   pdata->list       = list;
4254   pdata->top_length = top_length;
4255   pdata->countdown  = count;
4256   pdata->countup    = -1;
4257   pdata->stop_on    = stop_on;
4258   pdata->style      = style;
4259   return PTR2PKO(pbox);
4260 }
4261 /*_     , Copying */
4262 pko
4263 copy_listloop(const kt_listloop * orig)
4264 {
4265   ALLOC_BOX_PRESUME(kt_listloop,T_LISTLOOP);
4266   memcpy (pdata, orig, sizeof(kt_listloop));
4267   return PTR2PKO(pbox);
4268 }
4269 /*_    . Testing */
4270 /* Unused so far */
4271 DEF_T_PRED(is_listloop,       T_LISTLOOP,       no, "");
4272 DEF_T_PRED(is_listloop_style, T_LISTLOOP_STYLE, no, "");
4273 /*_    . Val-makers */
4274 /*_    . Pre-existing style objects */
4275 /*_     , listloop-style-sequence */
4276 RGSTR(simple,"listloop-style-sequence",REF_OBJ(sequence_style))
4277 static BOX_OF(kt_listloop_style) sequence_style =
4278 {
4279   T_LISTLOOP_STYLE,
4280   {
4281     REF_OPER(kernel_eval),
4282     0,
4283     lls_1list,
4284     0,
4285     K_NO_TYPE,                  /* No args contemplated */
4286     { [0 ... lls_num_args - 1] = -1, }
4287   }
4288 };
4289 /*_     , listloop-style-neighbors */
4290 RGSTR(simple,"listloop-style-neighbors",REF_OBJ(neighbor_style))
4291 SIG_CHKARRAY(neighbor_style) =
4292   {
4293     REF_OPER(is_integer),
4294   };
4295 DEF_SIMPLE_DESTR(neighbor_style);
4296 static BOX_OF(kt_listloop_style) neighbor_style =
4297 {
4298   T_LISTLOOP_STYLE,
4299   {
4300     REF_OPER(val2val),
4301     1,
4302     lls_neighbors,
4303     0,
4304     REF_DESTR(neighbor_style),
4305     /* See http://gcc.gnu.org/onlinedocs/gcc/Designated-Inits.html. */
4306     { [0 ... lls_num_args - 1] = -1, [lls_count] = 0, },
4307   }
4308 };
4309 /*_    . Operations */
4310 /*_     , listloop */
4311 /* Create a listloop object. */
4312 /* $$IMPROVE ME This may become what style operative T_ type calls.
4313    Rename it eval_listloop_style. */
4314 SIG_CHKARRAY(listloop) =
4315 {
4316   REF_OPER(is_listloop_style),
4317   REF_OPER(is_countable_list),
4318   REF_KEY(K_TYCH_DOT),
4319   K_ANY,
4320 };
4321
4322 DEF_SIMPLE_APPLICATIVE(ps0a3, listloop,0,ground, "listloop")
4323 {
4324   WITH_3_ARGS(style, list, args);
4325
4326   WITH_UNBOXED_UNSAFE(style_v,kt_listloop_style, style);
4327   pko style_args[lls_num_args];
4328   /* Destructure the args by style */
4329   destructure_to_array(sc,
4330                        args,
4331                        style_v->destructurer,
4332                        style_args,
4333                        lls_num_args,
4334                        REF_OPER (listloop_resume),
4335                        LIST2 (style, list),
4336                        style);
4337   return listloop_aux (sc, style_v, list, style_args);
4338 }
4339 /*_     , listloop_resume */
4340 SIG_CHKARRAY (listloop_resume) =
4341 {
4342   REF_OPER (is_destr_result),
4343   REF_OPER(is_listloop_style),
4344   REF_OPER(is_countable_list),
4345 };
4346 DEF_SIMPLE_CFUNC(ps0a3, listloop_resume, 0)
4347 {
4348   WITH_3_ARGS (destr_result, style, list);
4349   pko style_args[lls_num_args];
4350   destr_result_fill_array (destr_result, lls_num_args, style_args);
4351   WITH_UNBOXED_UNSAFE(style_v,kt_listloop_style, style);
4352   return listloop_aux (sc, style_v, list, style_args);
4353 }
4354 /*_     , listloop_aux */
4355 pko
4356 listloop_aux
4357 (klink * sc, kt_listloop_style * style_v, pko list, pko style_args[lls_num_args])
4358 {
4359   /*** Get the actual arg objects ***/
4360 #define GET_OBJ(_INDEX) \
4361   ((style_v->arg_select[_INDEX] < 0) ? K_INERT : style_args[style_v->arg_select[_INDEX]])
4362
4363   pko count      = GET_OBJ(lls_count);
4364   pko combiner   = GET_OBJ(lls_combiner);
4365   pko top_length = GET_OBJ(lls_top_count);
4366 #undef GET_OBJ
4367
4368   /*** Extract values from the objects, using defaults as needed ***/
4369   int countv      = (count      == K_INERT) ? -1L : ivalue(count);
4370   int top_lengthv = (top_length == K_INERT) ? 1 : ivalue(top_length);
4371   if(combiner == K_INERT)
4372     {
4373       combiner = style_v->combiner;
4374     }
4375
4376   /*** Make the loop object itself ***/
4377   pko ll = mk_listloop( combiner, list, top_lengthv, countv, 0, style_v );
4378   return ll;
4379 }
4380 /*_     , Evaluating one iteration */
4381 pko
4382 eval_listloop(klink * sc, pko functor, pko value)
4383 {
4384   WITH_REPORTER(sc);
4385   WITH_PSYC_UNBOXED(kt_listloop, functor, T_LISTLOOP, sc);
4386
4387   /*** Test whether done, maybe return current value. ***/
4388   /* If we're not checking, value will be NULL so this won't
4389      trigger.  pdata->countup is 0 for the first element. */
4390   if((pdata->countup >= 0) && (value == pdata->stop_on))
4391     {
4392       /* $$IMPROVE ME  This will ct an "abnormal return" value from
4393          this and the other data.  */
4394       return value;
4395     }
4396   /* If we're not counting down, value will be negative so this won't
4397      trigger.  */
4398   if(pdata->countdown == 0)
4399     {
4400       return value;
4401     }
4402   /* And if we run out of elements, we have to stop regardless. */
4403   if(pdata->list == K_NIL)
4404     {
4405       /* $$IMPROVE ME Error if we're counting down (ie, if count
4406          is positive). */
4407       return value;
4408     }
4409
4410   /*** Step list, getting new value ***/
4411   pko new_list, new_value;
4412
4413   switch(pdata->style->step)
4414     {
4415     case lls_1list:
4416       new_list  = cdr( pdata->list );
4417       /* We assume the common case of val as list. */
4418       new_value = LIST1(car( pdata->list ));
4419       break;
4420
4421     case lls_neighbors:
4422       /* $$IMPROVE ME Also test that next item (new_list) is non-empty */
4423       new_list  = cdr( pdata->list );
4424       new_value = LIST2(car( pdata->list ), car(new_list));
4425       break;
4426     case lls_many:
4427       new_list  = k_counted_map_cdr(sc, pdata->top_length, pdata->list, T_PAIR);
4428       new_value = k_counted_map_car(sc, pdata->top_length, pdata->list, T_PAIR);
4429       break;
4430     default:
4431       KERNEL_ERROR_0(sc,"I know nut-ting about that case");
4432     }
4433
4434   /* Convert it if applicable. */
4435   if(pdata->style->mk_val)
4436     {
4437       new_value = pdata->style->mk_val(new_value, pdata);
4438     }
4439
4440   /*** Arrange a new iteration. ***/
4441   /* We don't have to re-setup the final chain, if any, because it's
4442      still there from the earlier call.  Just the combiner (if any)
4443      and a fresh listloop operative.  */
4444   pko new_listloop = copy_listloop(pdata);
4445   {
4446     WITH_UNBOXED_UNSAFE(new_pdata,kt_listloop,new_listloop);
4447     new_pdata->list = new_list;
4448     if(new_pdata->countdown > 0)
4449       { new_pdata->countdown--; }
4450     new_pdata->countup++;
4451   }
4452
4453   if(pdata->style->collect_p)
4454     {
4455       CONTIN_0_RAW (mk_curried(dcrry_NVLLdotALL, value, new_listloop), sc);
4456     }
4457   else
4458     {
4459       CONTIN_0_RAW(new_listloop, sc);
4460     }
4461
4462   CONTIN_0_RAW(pdata->combiner, sc);
4463   return new_value;
4464 }
4465
4466 /*_  . Handling lists */
4467 /*_   , list* */
4468 DEF_APPLICATIVE_W_DESTR (ps0a1, list_star, REF_OPER(is_finite_list),T_NO_K,ground, "list*")
4469 {
4470   return v2list_star(sc, arg1, T_PAIR);
4471 }
4472 /*_   , reverse */
4473 SIG_CHKARRAY(reverse) = { REF_OPER(is_finite_list), };
4474 DEF_SIMPLE_APPLICATIVE (ps0a1, reverse,T_NO_K,ground, "reverse")
4475 {
4476   WITH_1_ARGS(a);
4477   return v2reverse(a,T_PAIR);
4478 }
4479 /*_    . reverse list -- in-place */
4480 /* Don't just use unsafe_v2reverse_in_place, it checks nothing.  This
4481    may be reserved for optimization only. */
4482
4483 /*_    . append list -- produce new list */
4484 /* $$IMPROVE ME  This defines append/2 but we'll want append/N.  Do
4485    that in init. */
4486 SIG_CHKARRAY(append) = { REF_OPER(is_finite_list), K_ANY, };
4487 DEF_SIMPLE_APPLICATIVE (ps0a2, append,T_NO_K,simple, "append")
4488 {
4489   WITH_2_ARGS(a,b);
4490   return v2append(sc,a,b,T_PAIR);
4491 }
4492 /*_   , is_finite_list */
4493 DEF_SIMPLE_PRED (is_finite_list,T_NO_K,ground, "finite-list?/o1")
4494 {
4495   WITH_1_ARGS(p);
4496   int4 metrics;
4497   get_list_metrics_aux(p, metrics);
4498   return (metrics[lm_num_nils] == 1);
4499 }
4500 /*_   , is_countable_list */
4501 DEF_SIMPLE_PRED (is_countable_list,T_NO_K,ground, "countable-list?/o1")
4502 {
4503   WITH_1_ARGS(p);
4504   int4 metrics;
4505   get_list_metrics_aux(p, metrics);
4506   return (metrics[lm_num_nils] || metrics[lm_cyc_len]);
4507 }
4508 /*_   , list_length */
4509 /* Result is:
4510    proper list: length
4511    circular list: -1
4512    not even a pair: -2
4513    dotted list: -2 minus length before dot
4514
4515    The extra meanings will change since callers can use
4516    get_list_metrics_aux now.  Return lm_acyc_len even for dotted
4517    lists, return positive infinity for circular lists.
4518 */
4519 /* $$OBSOLESCENT */
4520 int
4521 list_length (pko p)
4522 {
4523   int4 metrics;
4524   get_list_metrics_aux(p, metrics);
4525   /* A proper list */
4526   if(metrics[lm_num_nils] == 1)
4527     { return metrics[lm_acyc_len]; }
4528   /* A circular list */
4529   /* $$IMPROVE ME Return +oo.  First make a type and object for +oo  */
4530   if(metrics[lm_cyc_len] != 0)
4531     { return -1; }
4532   /* $$IMPROVE ME Return lm_acyc_len again, merge with the other
4533      case. */
4534   /* Otherwise it's dotted */
4535   return 2 - metrics[lm_acyc_len];
4536 }
4537 /*_   , list_length_k */
4538 DEF_APPLICATIVE_W_DESTR(p00a1, list_length_k, K_ANY_SINGLETON,T_NO_K,ground, "length")
4539 {
4540   WITH_1_ARGS(p);
4541   return mk_integer(list_length(p));
4542 }
4543
4544 /*_   , get_list_metrics */
4545 DEF_APPLICATIVE_W_DESTR(p00a1, get_list_metrics, K_ANY_SINGLETON,T_NO_K,ground, "get-list-metrics")
4546 {
4547   WITH_1_ARGS(p);
4548   int4 metrics;
4549   get_list_metrics_aux(p, metrics);
4550   return LIST4(mk_integer(metrics[0]),
4551                mk_integer(metrics[1]),
4552                mk_integer(metrics[2]),
4553                mk_integer(metrics[3]));
4554 }
4555 /*_   , get_list_metrics_aux */
4556 /* RESULTS must be an int4 (an array of 4 integers).  get_list_metrics_aux
4557    will fill it with (See enum lm_index):
4558
4559    * the number of pairs in a
4560    * the number of nil objects in a
4561    * the acyclic prefix length of a
4562    * the cycle length of a
4563 */
4564
4565 /* $$IMPROVE ME Take a flag so we can skip work such as finding
4566    prefix-length when we don't need to do it.  This will cause some
4567    result positions to be interpreted differently: when it's cycling,
4568    lm_acyc_len and lm_num_pairs may both overshoot (but never
4569    undershoot).
4570 */
4571
4572 void
4573 get_list_metrics_aux (pko a, int4 presults)
4574 {
4575   int * results = presults;     /* Make it easier to index. */
4576   int steps = 0;
4577   int power = 1;
4578   int loop_len = 1;
4579   pko slow, fast;
4580   WITH_REPORTER(0);
4581
4582   /* Use Brent's Algorithm, but we have to check for nil and non-pair
4583      too, so I rearranged the loop.  We also count steps, because in
4584      some cases we use number of steps directly. */
4585   slow = fast = a;
4586   while (1)
4587     {
4588       if (fast == K_NIL)
4589         {
4590           results[lm_num_pairs] = steps;
4591           results[lm_num_nils]  = 1;
4592           results[lm_acyc_len]  = steps;
4593           results[lm_cyc_len]   = 0;
4594           return;
4595         }
4596       if (!is_pair (fast))
4597         {
4598           results[lm_num_pairs] = steps;
4599           results[lm_num_nils]  = 0;
4600           results[lm_acyc_len]  = steps;
4601           results[lm_cyc_len]   = 0;
4602           return;
4603         }
4604       fast = cdr (fast);
4605       if (fast == slow)
4606         {
4607           /* The fast cursor has caught up with the slow cursor so the
4608              structure is circular and loop_len is the cycle length.
4609              We still need to find prefix length.
4610           */
4611           int prefix_len = 0;
4612           int i = 0;
4613           /* Restart the turtle from the beginning */
4614           slow = a;
4615           /* Restart the hare from position LOOP_LEN */
4616           for(i = 0, fast = a; i < loop_len; i++)
4617             { fast = cdr (fast); }
4618           /* Since hare has exactly a loop_len head start, when it
4619              goes around the loop exactly once it will be in the same
4620              position as turtle, so turtle will have only walked the
4621              acyclic prefix. */
4622           while(fast != slow)
4623             {
4624               fast = cdr (fast);
4625               slow = cdr (slow);
4626               prefix_len++;
4627             }
4628
4629           results[lm_num_pairs] = prefix_len + loop_len;
4630           results[lm_num_nils]  = 0;
4631           results[lm_acyc_len]  = prefix_len;
4632           results[lm_cyc_len]   = loop_len;
4633           return;
4634         }
4635       if(power == loop_len)
4636         {
4637           /* Re-plant the slow cursor */
4638           slow = fast;
4639           loop_len = 0;
4640           power *= 2;
4641         }
4642       ++loop_len;
4643       ++steps;
4644     }
4645 }
4646 /*_  . Handling trees */
4647 /*_   , copy_es_immutable */
4648 DEF_APPLICATIVE_W_DESTR (ps0a1, copy_es_immutable, K_ANY_SINGLETON,T_NO_K,ground, "copy-es-immutable")
4649 {
4650   WITH_1_ARGS(object);
4651   WITH_REPORTER(sc);
4652   if (is_pair (object))
4653     {
4654       /* If it's already immutable, can we assume it's immutable
4655        * all the way down and just return it? */
4656       return cons
4657         (copy_es_immutable (sc, car (object)),
4658          copy_es_immutable (sc, cdr (object)));
4659     }
4660   else
4661     {
4662       return object;
4663     }
4664 }
4665 /*_   , Get tree cycles */
4666 /*_    . Structs */
4667 /*_     , kt_recurrence_table */
4668 /* Really just a specialized resizeable lookup table from object to
4669    count.  Internals may change.  */
4670 /* $$IMPROVE ME Look up more efficiently.  Current GC is not
4671    compacting, so we can hash or sort addresses meaningfully.  */
4672 typedef struct
4673 {
4674   pko * objs;
4675   int     * counts;
4676   int table_size;
4677   int alloced_size;
4678 }
4679 kt_recurrence_table;
4680 /*_     , recur_entry */
4681 typedef struct
4682 {
4683   /* $$IMPROVE ME  These two fields may become one enumerated field */
4684   int count;
4685   int seen_in_walk;
4686   int index_in_walk;
4687 } recur_entry;
4688 /*_     , kt_recur_tracker */
4689 typedef struct
4690 {
4691   pko     * objs;
4692   recur_entry * entries;
4693   int table_size;
4694   int current_index;
4695 } kt_recur_tracker;
4696 /*_    . is_recurrence_table */
4697 DEF_T_PRED(is_recurrence_table,T_RECURRENCES,ground, "recurrence-table?/o1");
4698
4699 /*_    . is_recur_tracker */
4700 DEF_SIMPLE_PRED(is_recur_tracker,T_NO_K,ground, "recur-tracker?/o1")
4701 {
4702   WITH_1_ARGS(p);
4703   return (p == K_NIL) || is_type (p, T_RECUR_TRACKER);
4704 }
4705 /*_    . recurrences_to_recur_tracker */
4706 SIG_CHKARRAY(recurrences_to_recur_tracker) =
4707 { REF_OPER(is_recurrence_table), };
4708 DEF_SIMPLE_APPLICATIVE(p00a1,recurrences_to_recur_tracker,T_NO_K,ground, "recurrences->tracker")
4709 {
4710   WITH_1_ARGS(recurrences);
4711   assert_type(0,recurrences,T_RECURRENCES);
4712
4713   WITH_UNBOXED_UNSAFE(ptable, kt_recurrence_table,recurrences);
4714   /* $$IMPROVE ME Scan for counts > 1, and if there are none,
4715      return K_NIL. */
4716   if(ptable->table_size == 0)
4717     { return K_NIL; }
4718   {
4719     ALLOC_BOX_PRESUME(kt_recur_tracker,T_RECUR_TRACKER);
4720     /* $$MAKE ME SAFE This assumes that sharing is OK, recurrences
4721        won't mutate the LUT.  When we have COW or similar, make it
4722        safe.  At least check for immutability.  */
4723     pdata->objs       = ptable->objs;
4724     pdata->table_size = ptable->table_size;
4725     pdata->current_index = 0;
4726     pdata->entries =
4727       GC_MALLOC_ATOMIC(sizeof(recur_entry) * ptable->table_size);
4728     int i;
4729     for(i = 0; i < ptable->table_size; i++)
4730       {
4731         recur_entry * p_entry = &pdata->entries[i];
4732         p_entry->count = ptable->counts[i];
4733         p_entry->index_in_walk = 0;
4734         p_entry->seen_in_walk  = 0;
4735       }
4736     return PTR2PKO(pbox);
4737   }
4738 }
4739 /*_    . recurrences_list_objects */
4740 /* $$WRITE ME  Get a list of all objects and their recurrence counts */
4741 /*_    . objtable_get_index */
4742 int
4743 objtable_get_index
4744 (pko * objs, int table_size, pko obj)
4745 {
4746   int i;
4747   for(i = 0; i < table_size; i++)
4748     {
4749       if(obj == objs[i])
4750         { return i; }
4751     }
4752   return -1;
4753 }
4754 /*_    . recurrences_get_seen_count */
4755 /* Return the number of times OBJ has been seen before.  If "add" is
4756    non-zero, increment the count too (but return its previous
4757    value).  */
4758 int
4759 recurrences_get_seen_count
4760 (kt_recurrence_table * p_cycles_data, pko obj, int add)
4761 {
4762   int index = objtable_get_index(p_cycles_data->objs,
4763                                  p_cycles_data->table_size,
4764                                  obj);
4765   if(index >= 0)
4766     {
4767       int count = p_cycles_data->counts[index];
4768       /* Maybe record another sighting of this object. */
4769       if(add)
4770         { p_cycles_data->counts[index]++; }
4771       /* We've found our return value. */
4772       return count;
4773     }
4774
4775   /* We only get here if search didn't find anything. */
4776   /* Make sure we have enough space for this object. */
4777   if(add)
4778     {
4779       if(p_cycles_data->table_size == p_cycles_data->alloced_size)
4780         {
4781           p_cycles_data->alloced_size *= 2;
4782           p_cycles_data->counts = GC_REALLOC(p_cycles_data->counts, sizeof(int) * p_cycles_data->alloced_size);
4783           p_cycles_data->objs = GC_REALLOC(p_cycles_data->objs, sizeof(pko) * p_cycles_data->alloced_size);
4784         }
4785       int index = p_cycles_data->table_size;
4786       /* Record what it was */
4787       p_cycles_data->objs[index] = obj;
4788       /* We have now seen it once. */
4789       p_cycles_data->counts[index] = 1;
4790       p_cycles_data->table_size++;
4791     }
4792   return 0;
4793 }
4794 /*_    . recurrences_get_object_count */
4795 /* Given an object, list its count */
4796 SIG_CHKARRAY(recurrences_get_object_count) =
4797 { REF_OPER(is_recurrence_table), K_ANY, };
4798 DEF_SIMPLE_APPLICATIVE(p00a2, recurrences_get_object_count,T_NO_K,ground, "recurrences-get-object-count")
4799 {
4800   WITH_2_ARGS(table, obj);
4801   WITH_PSYC_UNBOXED(kt_recurrence_table,table, T_RECURRENCES, 0);
4802   int seen_count = recurrences_get_seen_count(pdata, obj, 0);
4803   return mk_integer(seen_count);
4804 }
4805 /*_    . init_recurrence_table */
4806 void
4807 init_recurrence_table(kt_recurrence_table * p_cycles_data, int initial_size)
4808 {
4809   p_cycles_data->objs   = initial_size ?
4810     GC_MALLOC(sizeof(pko) * initial_size) : 0;
4811   p_cycles_data->counts = initial_size ?
4812     GC_MALLOC(sizeof(int) * initial_size)     : 0;
4813   p_cycles_data->alloced_size = initial_size;
4814   p_cycles_data->table_size = 0;
4815 }
4816 /*_    . trace_tree_cycles */
4817 static void
4818 trace_tree_cycles
4819 (pko tree, kt_recurrence_table * p_cycles_data)
4820 {
4821   /* Special case for the "empty container", not because it's just a
4822      key but because "exploring" it does nothing. */
4823   if (tree == K_NIL)
4824     { return; }
4825   /* Maybe skip this object entirely */
4826   /* $$IMPROVE ME Parameterize this */
4827   switch(_get_type(tree))
4828     {
4829     case T_SYMBOL:
4830     case T_NUMBER:
4831       return;
4832     default:
4833       break;
4834     }
4835   if(recurrences_get_seen_count(p_cycles_data,tree, 1) != 0)
4836     { return; }
4837
4838   /* Switch on tree type */
4839   switch(_get_type(tree))
4840     {
4841     case T_PAIR:
4842       {
4843 #define _EXPLORE_FUNC(X) trace_tree_cycles(X, p_cycles_data)
4844         EXPLORE_v2(tree);
4845 #undef _EXPLORE_FUNC
4846         break;
4847       }
4848     default:
4849       break;
4850       /* Done this exploration */
4851     }
4852   return;
4853 }
4854
4855 /*_    . get_recurrences */
4856 SIG_CHKARRAY(get_recurrences) = { K_ANY, };
4857 DEF_SIMPLE_APPLICATIVE (ps0a1, get_recurrences,T_NO_K,ground, "get-recurrences")
4858 {
4859   WITH_1_ARGS(tree);
4860   /* No reason to even start exploring non-containers */
4861   /* $$IMPROVE ME  Allow containers other than pairs */
4862   int explore_p = (_get_type(tree) == T_PAIR);
4863   ALLOC_BOX_PRESUME(kt_recurrence_table, T_RECURRENCES);
4864   init_recurrence_table(pdata, explore_p ? 8 : 0);
4865   if(explore_p)
4866     { trace_tree_cycles(tree,pdata); }
4867   return PTR2PKO(pbox);
4868 }
4869
4870 /*_  . Reading */
4871
4872 /*_   , Making result objects */
4873
4874 /* make symbol or number atom from string */
4875 static pko
4876 mk_atom (klink * sc, char *q)
4877 {
4878   char c, *p;
4879   int has_dec_point = 0;
4880   int has_fp_exp = 0;
4881
4882 #if USE_COLON_HOOK
4883   if ((p = strstr (q, "::")) != 0)
4884     {
4885       *p = 0;
4886       return mcons (sc->COLON_HOOK,
4887                    mcons (mcons (sc->QUOTE,
4888                                mcons (mk_atom (sc, p + 2), K_NIL)),
4889                          mcons (mk_symbol (strlwr (q)), K_NIL)));
4890     }
4891 #endif
4892
4893   p = q;
4894   c = *p++;
4895   if ((c == '+') || (c == '-'))
4896     {
4897       c = *p++;
4898       if (c == '.')
4899         {
4900           has_dec_point = 1;
4901           c = *p++;
4902         }
4903       if (!isdigit (c))
4904         {
4905           return (mk_symbol (strlwr (q)));
4906         }
4907     }
4908   else if (c == '.')
4909     {
4910       has_dec_point = 1;
4911       c = *p++;
4912       if (!isdigit (c))
4913         {
4914           return (mk_symbol (strlwr (q)));
4915         }
4916     }
4917   else if (!isdigit (c))
4918     {
4919       return (mk_symbol (strlwr (q)));
4920     }
4921
4922   for (; (c = *p) != 0; ++p)
4923     {
4924       if (!isdigit (c))
4925         {
4926           if (c == '.')
4927             {
4928               if (!has_dec_point)
4929                 {
4930                   has_dec_point = 1;
4931                   continue;
4932                 }
4933             }
4934           else if ((c == 'e') || (c == 'E'))
4935             {
4936               if (!has_fp_exp)
4937                 {
4938                   has_dec_point = 1;    /* decimal point illegal
4939                                            from now on */
4940                   p++;
4941                   if ((*p == '-') || (*p == '+') || isdigit (*p))
4942                     {
4943                       continue;
4944                     }
4945                 }
4946             }
4947           return (mk_symbol (strlwr (q)));
4948         }
4949     }
4950   if (has_dec_point)
4951     {
4952       return mk_real (atof (q));
4953     }
4954   return (mk_integer (atol (q)));
4955 }
4956
4957 /* make constant */
4958 static pko
4959 mk_sharp_const (char *name)
4960 {
4961   long x;
4962   char tmp[STRBUFFSIZE];
4963
4964   if (!strcmp (name, "t"))
4965     return (K_T);
4966   else if (!strcmp (name, "f"))
4967     return (K_F);
4968   else if (!strcmp (name, "ignore"))
4969     return (K_IGNORE);
4970   else if (!strcmp (name, "inert"))
4971     return (K_INERT);
4972   else if (*name == 'o')
4973     {                           /* #o (octal) */
4974       snprintf (tmp, STRBUFFSIZE, "0%s", name + 1);
4975       sscanf (tmp, "%lo", &x);
4976       return (mk_integer (x));
4977     }
4978   else if (*name == 'd')
4979     {                           /* #d (decimal) */
4980       sscanf (name + 1, "%ld", &x);
4981       return (mk_integer (x));
4982     }
4983   else if (*name == 'x')
4984     {                           /* #x (hex) */
4985       snprintf (tmp, STRBUFFSIZE, "0x%s", name + 1);
4986       sscanf (tmp, "%lx", &x);
4987       return (mk_integer (x));
4988     }
4989   else if (*name == 'b')
4990     {                           /* #b (binary) */
4991       x = binary_decode (name + 1);
4992       return (mk_integer (x));
4993     }
4994   else if (*name == '\\')
4995     {                           /* #\w (character) */
4996       int c = 0;
4997       if (stricmp (name + 1, "space") == 0)
4998         {
4999           c = ' ';
5000         }
5001       else if (stricmp (name + 1, "newline") == 0)
5002         {
5003           c = '\n';
5004         }
5005       else if (stricmp (name + 1, "return") == 0)
5006         {
5007           c = '\r';
5008         }
5009       else if (stricmp (name + 1, "tab") == 0)
5010         {
5011           c = '\t';
5012         }
5013       else if (name[1] == 'x' && name[2] != 0)
5014         {
5015           int c1 = 0;
5016           if (sscanf (name + 2, "%x", &c1) == 1 && c1 < UCHAR_MAX)
5017             {
5018               c = c1;
5019             }
5020           else
5021             {
5022               return K_NIL;
5023             }
5024 #if USE_ASCII_NAMES
5025         }
5026       else if (is_ascii_name (name + 1, &c))
5027         {
5028           /* nothing */
5029 #endif
5030         }
5031       else if (name[2] == 0)
5032         {
5033           c = name[1];
5034         }
5035       else
5036         {
5037           return K_NIL;
5038         }
5039       return mk_character (c);
5040     }
5041   else
5042     return (K_NIL);
5043 }
5044
5045 /*_   , Reading strings */
5046 /* read characters up to delimiter, but cater to character constants */
5047 static char *
5048 readstr_upto (klink * sc, char *delim)
5049 {
5050   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5051
5052   char *p = sc->strbuff;
5053
5054   while ((p - sc->strbuff < sizeof (sc->strbuff)) &&
5055          !is_one_of (delim, (*p++ = inchar (pt))));
5056
5057   if (p == sc->strbuff + 2 && p[-2] == '\\')
5058     {
5059       *p = 0;
5060     }
5061   else
5062     {
5063       backchar (pt, p[-1]);
5064       *--p = '\0';
5065     }
5066   return sc->strbuff;
5067 }
5068
5069 /* skip white characters */
5070 static INLINE int
5071 skipspace (klink * sc)
5072 {
5073   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5074   int c = 0;
5075
5076   do
5077     { c = inchar (pt); }
5078   while (isspace (c));
5079   if (c != EOF)
5080     {
5081       backchar (pt, c);
5082       return 1;
5083     }
5084   else
5085     { return EOF; }
5086 }
5087
5088 /*_   , Utilities */
5089 /* check c is in chars */
5090 static INLINE int
5091 is_one_of (char *s, int c)
5092 {
5093   if (c == EOF)
5094     return 1;
5095   while (*s)
5096     if (*s++ == c)
5097       return (1);
5098   return (0);
5099 }
5100
5101 /*_   , Reading expressions */
5102 /* read string expression "xxx...xxx" */
5103 static pko
5104 readstrexp (klink * sc)
5105 {
5106   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5107   char *p = sc->strbuff;
5108   int c;
5109   int c1 = 0;
5110   enum
5111   { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
5112
5113   for (;;)
5114     {
5115       c = inchar (pt);
5116       if (c == EOF || p - sc->strbuff > sizeof (sc->strbuff) - 1)
5117         {
5118           return K_F;
5119         }
5120       switch (state)
5121         {
5122         case st_ok:
5123           switch (c)
5124             {
5125             case '\\':
5126               state = st_bsl;
5127               break;
5128             case '"':
5129               *p = 0;
5130               return mk_counted_string (sc->strbuff, p - sc->strbuff);
5131             default:
5132               *p++ = c;
5133               break;
5134             }
5135           break;
5136         case st_bsl:
5137           switch (c)
5138             {
5139             case '0':
5140             case '1':
5141             case '2':
5142             case '3':
5143             case '4':
5144             case '5':
5145             case '6':
5146             case '7':
5147               state = st_oct1;
5148               c1 = c - '0';
5149               break;
5150             case 'x':
5151             case 'X':
5152               state = st_x1;
5153               c1 = 0;
5154               break;
5155             case 'n':
5156               *p++ = '\n';
5157               state = st_ok;
5158               break;
5159             case 't':
5160               *p++ = '\t';
5161               state = st_ok;
5162               break;
5163             case 'r':
5164               *p++ = '\r';
5165               state = st_ok;
5166               break;
5167             case '"':
5168               *p++ = '"';
5169               state = st_ok;
5170               break;
5171             default:
5172               *p++ = c;
5173               state = st_ok;
5174               break;
5175             }
5176           break;
5177         case st_x1:
5178         case st_x2:
5179           c = toupper (c);
5180           if (c >= '0' && c <= 'F')
5181             {
5182               if (c <= '9')
5183                 {
5184                   c1 = (c1 << 4) + c - '0';
5185                 }
5186               else
5187                 {
5188                   c1 = (c1 << 4) + c - 'A' + 10;
5189                 }
5190               if (state == st_x1)
5191                 {
5192                   state = st_x2;
5193                 }
5194               else
5195                 {
5196                   *p++ = c1;
5197                   state = st_ok;
5198                 }
5199             }
5200           else
5201             {
5202               return K_F;
5203             }
5204           break;
5205         case st_oct1:
5206         case st_oct2:
5207           if (c < '0' || c > '7')
5208             {
5209               *p++ = c1;
5210               backchar (pt, c);
5211               state = st_ok;
5212             }
5213           else
5214             {
5215               if (state == st_oct2 && c1 >= 32)
5216                 return K_F;
5217
5218               c1 = (c1 << 3) + (c - '0');
5219
5220               if (state == st_oct1)
5221                 state = st_oct2;
5222               else
5223                 {
5224                   *p++ = c1;
5225                   state = st_ok;
5226                 }
5227             }
5228           break;
5229
5230         }
5231     }
5232 }
5233
5234
5235 /* get token */
5236 static int
5237 token (klink * sc)
5238 {
5239   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5240   int c;
5241   c = skipspace (sc);
5242   if (c == EOF)
5243     {
5244       return (TOK_EOF);
5245     }
5246   switch (c = inchar (pt))
5247     {
5248     case EOF:
5249       return (TOK_EOF);
5250     case '(':
5251       return (TOK_LPAREN);
5252     case ')':
5253       return (TOK_RPAREN);
5254     case '.':
5255       c = inchar (pt);
5256       if (is_one_of (" \n\t", c))
5257         {
5258           return (TOK_DOT);
5259         }
5260       else
5261         {
5262           backchar (pt, c);
5263           backchar (pt, '.');
5264           return TOK_ATOM;
5265         }
5266     case '\'':
5267       return (TOK_QUOTE);
5268     case ';':
5269       while ((c = inchar (pt)) != '\n' && c != EOF)
5270         {}
5271
5272       if (c == EOF)
5273         {
5274           return (TOK_EOF);
5275         }
5276       else
5277         {
5278           return (token (sc));
5279         }
5280     case '"':
5281       return (TOK_DQUOTE);
5282     case '`':
5283       return (TOK_BQUOTE);
5284     case ',':
5285       if ((c = inchar (pt)) == '@')
5286         {
5287           return (TOK_ATMARK);
5288         }
5289       else
5290         {
5291           backchar (pt, c);
5292           return (TOK_COMMA);
5293         }
5294     case '#':
5295       c = inchar (pt);
5296       if (c == '(')
5297         {
5298           return (TOK_VEC);
5299         }
5300       else if (c == '!')
5301         {
5302           while ((c = inchar (pt)) != '\n' && c != EOF)
5303             {}
5304
5305           if (c == EOF)
5306             {
5307               return (TOK_EOF);
5308             }
5309           else
5310             {
5311               return (token (sc));
5312             }
5313         }
5314       else
5315         {
5316           backchar (pt, c);
5317           /* $$UNHACKIFY ME!  This is a horrible hack. */
5318           if (is_one_of (" itfodxb\\", c))
5319             {
5320               return TOK_SHARP_CONST;
5321             }
5322           else
5323             {
5324               return (TOK_SHARP);
5325             }
5326         }
5327     default:
5328       backchar (pt, c);
5329       return (TOK_ATOM);
5330     }
5331 }
5332 /*_   , Nesting check */
5333 /*_    . create_nesting_check */
5334 void create_nesting_check(klink * sc)
5335 { klink_push_dyn_binding(sc,K_NEST_DEPTH,mk_integer(0)); }
5336 /*_    . nest_depth_ok_p */
5337 int nest_depth_ok_p(klink * sc)
5338 {
5339   pko nesting =
5340     klink_find_dyn_binding(sc,K_NEST_DEPTH);
5341   if(!nesting)
5342     { return 1; }
5343   return ivalue(nesting) == 0;
5344 }
5345 /*_    . change_nesting_depth */
5346 void change_nesting_depth(klink * sc, signed int change)
5347 {
5348   pko nesting =
5349     klink_find_dyn_binding(sc,K_NEST_DEPTH);
5350   add_to_ivalue(nesting,change);
5351 }
5352 /*_   , C-style entry points */
5353
5354 /*_    . kernel_read_internal */
5355 /* The only reason that this is separate from kernel_read_sexp is that
5356    it gets a token, which kernel_read_sexp does almost always, except
5357    once when a caller tricks it with TOK_LPAREN, and once when
5358    kernel_read_list effectively puts back a token it didn't decode.  */
5359 static
5360 DEF_APPLICATIVE_W_DESTR (ps0a0, kernel_read_internal, K_NO_TYPE,0,ground, "read")
5361 {
5362   token_t tok = token (sc);
5363   if (tok == TOK_EOF)
5364     {
5365       return K_EOF;
5366     }
5367   sc->tok = tok;
5368   create_nesting_check(sc);
5369   return kernel_read_sexp (sc);
5370 }
5371
5372 /*_    . kernel_read_sexp */
5373 DEF_CFUNC (ps0a0, kernel_read_sexp, K_NO_TYPE,0)
5374 {
5375   switch (sc->tok)
5376     {
5377     case TOK_EOF:
5378       return K_EOF;
5379       /* NOTREACHED */
5380     case TOK_VEC:
5381       CONTIN_0 (vector, sc);
5382
5383       /* fall through */
5384     case TOK_LPAREN:
5385       sc->tok = token (sc);
5386       if (sc->tok == TOK_RPAREN)
5387         {
5388           return K_NIL;
5389         }
5390       else if (sc->tok == TOK_DOT)
5391         {
5392           KERNEL_ERROR_0 (sc, "syntax error: illegal dot expression");
5393         }
5394       else
5395         {
5396           change_nesting_depth(sc, 1);
5397           CONTIN_1 (dcrry_2A01VLL, kernel_read_list, sc, K_NIL);
5398           CONTIN_0 (kernel_read_sexp, sc);
5399           return K_INERT;
5400         }
5401     case TOK_QUOTE:
5402       {
5403         pko pquote = REF_OPER(arg1);
5404         CONTIN_1 (dcrry_2A01VLL, val2val, sc, pquote);
5405       }
5406       sc->tok = token (sc);
5407       CONTIN_0 (kernel_read_sexp, sc);
5408       return K_INERT;
5409
5410     case TOK_BQUOTE:
5411       sc->tok = token (sc);
5412       if (sc->tok == TOK_VEC)
5413         {
5414           /* $$CLEAN ME Do this more cleanly than by changing tokens
5415              to trick it.  Maybe factor the TOK_LPAREN treatment so we
5416              can schedule it. */
5417           klink_push_cont (sc, REF_OPER (kernel_treat_qquoted_vec));
5418           sc->tok = TOK_LPAREN;
5419           /* $$CLEANUP Seems like this could be combined with the part
5420              afterwards */
5421           CONTIN_0 (kernel_read_sexp, sc);
5422           return K_INERT;
5423         }
5424       else
5425         {
5426           /* Punt for now: Give quoted symbols rather than actual
5427              operators. ,Similarly sc->UNQUOTE, sc->UNQUOTESP */
5428           CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->QQUOTE);
5429         }
5430
5431       CONTIN_0 (kernel_read_sexp, sc);
5432       return K_INERT;
5433
5434     case TOK_COMMA:
5435       CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->UNQUOTE);
5436       sc->tok = token (sc);
5437       CONTIN_0 (kernel_read_sexp, sc);
5438       return K_INERT;
5439     case TOK_ATMARK:
5440       CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->UNQUOTESP);
5441       sc->tok = token (sc);
5442       CONTIN_0 (kernel_read_sexp, sc);
5443       return K_INERT;
5444     case TOK_ATOM:
5445       return mk_atom (sc, readstr_upto (sc, "();\t\n\r "));
5446     case TOK_DQUOTE:
5447       {
5448         pko x = readstrexp (sc);
5449         if (x == K_F)
5450           {
5451             KERNEL_ERROR_0 (sc, "Error reading string");
5452           }
5453         setimmutable (x);
5454         return x;
5455       }
5456     case TOK_SHARP:
5457       {
5458         pko sharp_hook = sc->SHARP_HOOK;
5459         pko f =
5460           is_symbol(sharp_hook)
5461           ? find_slot_in_env (sc->envir, sharp_hook, 1)
5462           : K_NIL;
5463         if (f == 0)
5464           {
5465             KERNEL_ERROR_0 (sc, "undefined sharp expression");
5466           }
5467         else
5468           {
5469             pko form = mcons (slot_value_in_env (f), K_NIL);
5470             return kernel_eval (sc, form, sc->envir);
5471           }
5472       }
5473     case TOK_SHARP_CONST:
5474       {
5475         pko x = mk_sharp_const (readstr_upto (sc, "();\t\n\r "));
5476         if (x == K_NIL)
5477           {
5478             KERNEL_ERROR_0 (sc, "undefined sharp expression");
5479           }
5480         else
5481           {
5482             return x;
5483           }
5484       }
5485     default:
5486       KERNEL_ERROR_0 (sc, "syntax error: illegal token");
5487     }
5488 }
5489
5490 /*_    . Read list */
5491 /* $$IMPROVE ME  Use currying ops instead of accumulating by hand */
5492 SIG_CHKARRAY(kernel_read_list) = { REF_OPER(is_finite_list),  K_ANY, };
5493 DEF_SIMPLE_CFUNC (ps0a2, kernel_read_list,0)
5494 {
5495   WITH_2_ARGS (old_accum,value);
5496   pko accum = mcons (value, old_accum);
5497   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5498   sc->tok = token (sc);
5499   if (sc->tok == TOK_EOF)
5500     {
5501       return (K_EOF);
5502     }
5503   else if (sc->tok == TOK_RPAREN)
5504     {
5505       /* $$RECONSIDER ME Why is this done?  To accept CR from user? */
5506       int c = inchar (pt);
5507       if (c != '\n')
5508         {
5509           backchar (pt, c);
5510         }
5511       change_nesting_depth(sc, -1);
5512       return (unsafe_v2reverse_in_place (K_NIL, accum));
5513     }
5514   else if (sc->tok == TOK_DOT)
5515     {
5516       CONTIN_1 (dcrry_2A01VLL, kernel_treat_dotted_list, sc, accum);
5517       sc->tok = token (sc);
5518       CONTIN_0 (kernel_read_sexp, sc);
5519       return K_INERT;
5520     }
5521   else
5522     {
5523       CONTIN_1 (dcrry_2A01VLL, kernel_read_list, sc, accum);
5524       CONTIN_0 (kernel_read_sexp, sc);
5525       return K_INERT;
5526     }
5527 }
5528
5529 /*_    . Treat end of dotted list */
5530 static
5531 DEF_CFUNC (ps0a2, kernel_treat_dotted_list, REF_DESTR(kernel_read_list),T_NO_K)
5532 {
5533   WITH_2_ARGS(args,value);
5534
5535   if (token (sc) != TOK_RPAREN)
5536     {
5537       KERNEL_ERROR_0 (sc, "syntax error: illegal dot expression");
5538     }
5539   else
5540     {
5541       change_nesting_depth(sc, -1);
5542       return (unsafe_v2reverse_in_place (value, args));
5543     }
5544 }
5545
5546 /*_    . Treat quasiquoted vector */
5547 static
5548 DEF_CFUNC (ps0a1, kernel_treat_qquoted_vec, K_ANY,T_NO_K)
5549 {
5550   pko value = arg1;
5551   /* $$IMPROVE ME Include vector applicative directly, not by applying
5552      symbol.  This does need to apply, though, so that backquote (now
5553      seeing a list) can be run on "value" first*/
5554   return (mcons (mk_symbol ("apply"),
5555                 mcons (mk_symbol ("vector"),
5556                       mcons (mcons (sc->QQUOTE, mcons (value, K_NIL)),
5557                             K_NIL))));
5558 }
5559 /*_   , Loading files */
5560 /*_    . load_from_port */
5561 /* $$RETHINK ME  This soon need no longer be a cfunc */
5562 SIG_CHKARRAY(load_from_port) = { REF_OPER(is_inport), REF_OPER(is_environment)};
5563 DEF_SIMPLE_CFUNC(ps0a2,load_from_port,0)
5564 {
5565   WITH_2_ARGS(inport,env);
5566   assert (is_port(inport));
5567   assert (is_environment(env));
5568   /* Print that we're loading (If there's an outport, and we may want
5569      to add a verbosity condition based on a dynamic variable) */
5570   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5571   if(the_outport && (the_outport != K_NIL))
5572     {
5573       port * pt = portvalue(inport);
5574       if(pt->kind & port_file)
5575         {
5576           const char *fname = pt->rep.stdio.filename;
5577           if (!fname)
5578             { fname = "<unknown>"; }
5579           putstr(sc,"Loading ");
5580           putstr(sc,fname);
5581           putstr(sc,"\n");
5582         }
5583     }
5584
5585   /* We will do the evals in ENV */
5586   sc->envir = env;
5587   klink_push_dyn_binding(sc,K_INPORT,inport);
5588   return kernel_rel(sc);
5589 }
5590 /*_    . load */
5591 /* $$OBSOLETE */
5592 SIG_CHKARRAY(k_load_file) = { REF_OPER(is_string), };
5593 DEF_SIMPLE_APPLICATIVE(ps0a1,k_load_file,0,ground, "load")
5594 {
5595   WITH_1_ARGS(filename_ob);
5596   const char * filename = string_value(filename_ob);
5597   pko p = port_from_filename (filename, port_file | port_input);
5598   if (p == K_NIL)
5599     {
5600       KERNEL_ERROR_1(sc,"unable to open", filename_ob);
5601     }
5602
5603   return load_from_port(sc,p,sc->envir);
5604 }
5605 /*_    . get-module-from-port */
5606 SIG_CHKARRAY(k_get_mod_fm_port) =
5607   { REF_OPER(is_port), REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
5608 DEF_SIMPLE_APPLICATIVE(ps0a2,k_get_mod_fm_port,0,ground, "get-module-from-port")
5609 {
5610   WITH_2_ARGS(port, params);
5611   pko env = mk_std_environment();
5612   if(params != K_INERT)
5613     {
5614       assert(is_environment(params));
5615       kernel_define (env, mk_symbol ("module-parameters"), params);
5616     }
5617   /* Ultimately return that environment. */
5618   CONTIN_1R(dcrry_NdotALL,val2val,sc,env);
5619   return load_from_port(sc, port,env);
5620 }
5621
5622 /*_  . Printing */
5623 /*_   , Writing chars */
5624 INTERFACE void
5625 putstr (klink * sc, const char *s)
5626 {
5627   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5628   port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5629
5630   if (pt->kind & port_file)
5631     {
5632       fputs (s, pt->rep.stdio.file);
5633     }
5634   else
5635     {
5636       for (; *s; s++)
5637         {
5638           if (pt->rep.string.curr != pt->rep.string.past_the_end)
5639             {
5640               *pt->rep.string.curr++ = *s;
5641             }
5642           else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5643             {
5644               *pt->rep.string.curr++ = *s;
5645             }
5646         }
5647     }
5648 }
5649
5650 static void
5651 putchars (klink * sc, const char *s, int len)
5652 {
5653   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5654   port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5655
5656   if (pt->kind & port_file)
5657     {
5658       fwrite (s, 1, len, pt->rep.stdio.file);
5659     }
5660   else
5661     {
5662       for (; len; len--)
5663         {
5664           if (pt->rep.string.curr != pt->rep.string.past_the_end)
5665             {
5666               *pt->rep.string.curr++ = *s++;
5667             }
5668           else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5669             {
5670               *pt->rep.string.curr++ = *s++;
5671             }
5672         }
5673     }
5674 }
5675
5676 INTERFACE void
5677 putcharacter (klink * sc, int c)
5678 {
5679   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5680   port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5681
5682   if (pt->kind & port_file)
5683     {
5684       fputc (c, pt->rep.stdio.file);
5685     }
5686   else
5687     {
5688       if (pt->rep.string.curr != pt->rep.string.past_the_end)
5689         {
5690           *pt->rep.string.curr++ = c;
5691         }
5692       else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5693         {
5694           *pt->rep.string.curr++ = c;
5695         }
5696     }
5697 }
5698
5699 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == K_NIL)
5700
5701 static void
5702 printslashstring (klink * sc, char *p, int len)
5703 {
5704   int i;
5705   unsigned char *s = (unsigned char *) p;
5706   putcharacter (sc, '"');
5707   for (i = 0; i < len; i++)
5708     {
5709       if (*s == 0xff || *s == '"' || *s < ' ' || *s == '\\')
5710         {
5711           putcharacter (sc, '\\');
5712           switch (*s)
5713             {
5714             case '"':
5715               putcharacter (sc, '"');
5716               break;
5717             case '\n':
5718               putcharacter (sc, 'n');
5719               break;
5720             case '\t':
5721               putcharacter (sc, 't');
5722               break;
5723             case '\r':
5724               putcharacter (sc, 'r');
5725               break;
5726             case '\\':
5727               putcharacter (sc, '\\');
5728               break;
5729             default:
5730               {
5731                 int d = *s / 16;
5732                 putcharacter (sc, 'x');
5733                 if (d < 10)
5734                   {
5735                     putcharacter (sc, d + '0');
5736                   }
5737                 else
5738                   {
5739                     putcharacter (sc, d - 10 + 'A');
5740                   }
5741                 d = *s % 16;
5742                 if (d < 10)
5743                   {
5744                     putcharacter (sc, d + '0');
5745                   }
5746                 else
5747                   {
5748                     putcharacter (sc, d - 10 + 'A');
5749                   }
5750               }
5751             }
5752         }
5753       else
5754         {
5755           putcharacter (sc, *s);
5756         }
5757       s++;
5758     }
5759   putcharacter (sc, '"');
5760 }
5761
5762 /*_   , Printing atoms */
5763 static void
5764 printatom (klink * sc, pko l)
5765 {
5766   char *p;
5767   int len;
5768   atom2str (sc, l, &p, &len);
5769   putchars (sc, p, len);
5770 }
5771
5772
5773 /* Uses internal buffer unless string pointer is already available */
5774 static void
5775 atom2str (klink * sc, pko l, char **pp, int *plen)
5776 {
5777   WITH_REPORTER(sc);
5778   char *p;
5779   pko p_escapes = klink_find_dyn_binding(sc,K_PRINT_FLAG);
5780   int escapes = (p_escapes == K_T) ? 1 : 0;
5781
5782   if (l == K_NIL)
5783     {
5784       p = "()";
5785     }
5786   else if (l == K_T)
5787     {
5788       p = "#t";
5789     }
5790   else if (l == K_F)
5791     {
5792       p = "#f";
5793     }
5794   else if (l == K_INERT)
5795     {
5796       p = "#inert";
5797     }
5798   else if (l == K_IGNORE)
5799     {
5800       p = "#ignore";
5801     }
5802   else if (l == K_EOF)
5803     {
5804       p = "#<EOF>";
5805     }
5806   else if (is_port (l))
5807     {
5808       p = sc->strbuff;
5809       snprintf (p, STRBUFFSIZE, "#<PORT>");
5810     }
5811   else if (is_number (l))
5812     {
5813       p = sc->strbuff;
5814       if (num_is_integer (l))
5815         {
5816           snprintf (p, STRBUFFSIZE, "%ld", ivalue (l));
5817         }
5818       else
5819         {
5820           snprintf (p, STRBUFFSIZE, "%.10g", rvalue (l));
5821         }
5822     }
5823   else if (is_string (l))
5824     {
5825       if (!escapes)
5826         {
5827           p = string_value (l);
5828         }
5829       else
5830         {                       /* Hack, uses the fact that printing is needed */
5831           *pp = sc->strbuff;
5832           *plen = 0;
5833           printslashstring (sc, string_value (l), string_len (l));
5834           return;
5835         }
5836     }
5837   else if (is_character (l))
5838     {
5839       int c = charvalue (l);
5840       p = sc->strbuff;
5841       if (!escapes)
5842         {
5843           p[0] = c;
5844           p[1] = 0;
5845         }
5846       else
5847         {
5848           switch (c)
5849             {
5850             case ' ':
5851               snprintf (p, STRBUFFSIZE, "#\\space");
5852               break;
5853             case '\n':
5854               snprintf (p, STRBUFFSIZE, "#\\newline");
5855               break;
5856             case '\r':
5857               snprintf (p, STRBUFFSIZE, "#\\return");
5858               break;
5859             case '\t':
5860               snprintf (p, STRBUFFSIZE, "#\\tab");
5861               break;
5862             default:
5863 #if USE_ASCII_NAMES
5864               if (c == 127)
5865                 {
5866                   snprintf (p, STRBUFFSIZE, "#\\del");
5867                   break;
5868                 }
5869               else if (c < 32)
5870                 {
5871                   snprintf (p, STRBUFFSIZE, "#\\%s", charnames[c]);
5872                   break;
5873                 }
5874 #else
5875               if (c < 32)
5876                 {
5877                   snprintf (p, STRBUFFSIZE, "#\\x%x", c);
5878                   break;
5879                   break;
5880                 }
5881 #endif
5882               snprintf (p, STRBUFFSIZE, "#\\%c", c);
5883               break;
5884               break;
5885             }
5886         }
5887     }
5888   else if (is_symbol (l))
5889     {
5890       p = symname (sc,l);
5891     }
5892
5893
5894   else if (is_environment (l))
5895     {
5896       p = "#<ENVIRONMENT>";
5897     }
5898   else if (is_continuation (l))
5899     {
5900       p = "#<CONTINUATION>";
5901     }
5902   else if (is_operative (l)
5903            /* $$TRANSITIONAL  When these can be launched by
5904               themselves, this check will be folded into is_operative */
5905            || is_type (l, T_DESTRUCTURE)
5906            || is_type (l, T_TYPECHECK)
5907            || is_type (l, T_TYPEP))
5908     {
5909       /* $$TRANSITIONAL  This logic will move, probably into
5910          k_print_special_and_balk_p, and become more general. */
5911       pko slot =
5912         print_lookup_unwraps ?
5913         reverse_find_slot_in_env_aux(print_lookup_unwraps,l) :
5914         0;
5915       if(slot)
5916         {
5917           p = sc->strbuff;
5918           snprintf (p, STRBUFFSIZE, ",(unwrap #,%s)", symname(0, car(slot)));
5919         }
5920       else
5921         {
5922           pko slot =
5923             print_lookup_to_xary ?
5924             reverse_find_slot_in_env_aux(print_lookup_to_xary,l) :
5925             0;
5926           if(slot)
5927             {
5928               /* We don't say it's the tree-ary version, because the
5929                  tree-ary conversion is not exposed. */
5930               p = symname(0, car(slot));
5931             }
5932           else
5933             {
5934               pko slot =
5935                 all_builtins_env ?
5936                 reverse_find_slot_in_env_aux(all_builtins_env, l) :
5937                 0;
5938               if(slot)
5939                 {
5940                   p = symname(0, car(slot));
5941                 }
5942               else
5943                 { p = "#<OPERATIVE>"; }}
5944         }
5945     }
5946   else if (is_promise (l))
5947     {
5948       p = "#<PROMISE>";
5949     }
5950   else if (is_applicative (l))
5951     {
5952       p = "#<APPLICATIVE>";
5953     }
5954   else if (is_type (l, T_ENCAP))
5955     {
5956       p = "#<ENCAPSULATION>";
5957     }
5958   else if (is_type (l, T_KEY))
5959     {
5960       p = "#<KEY>";
5961     }
5962   else if (is_type (l, T_RECUR_TRACKER))
5963     {
5964       p = "#<RECURRENCE TRACKER>";
5965     }
5966   else if (is_type (l, T_RECURRENCES))
5967     {
5968       p = "#<RECURRENCE TABLE>";
5969     }
5970   else
5971     {
5972       p = sc->strbuff;
5973       snprintf (p, STRBUFFSIZE, "#<ERROR %d>", _get_type(l));
5974     }
5975   *pp = p;
5976   *plen = strlen (p);
5977 }
5978
5979 /*_   , C-style entry points */
5980 /*_    . Print sexp */
5981 /*_     , kernel_print_sexp */
5982 SIG_CHKARRAY(kernel_print_sexp) =
5983 { K_ANY, REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
5984 static
5985 DEF_SIMPLE_CFUNC (ps0a2, kernel_print_sexp,0)
5986 {
5987   WITH_2_ARGS(sexp, lookup_env);
5988   pko recurrences = get_recurrences(sc, sexp);
5989   pko tracker = recurrences_to_recur_tracker(recurrences);
5990   /* $$IMPROVE ME Default to an environment that knows sharp
5991      constants */
5992   return kernel_print_sexp_aux
5993     (sc, sexp,
5994      tracker,
5995      ((lookup_env == K_INERT) ? ground_env : lookup_env));
5996 }
5997 /*_     , k_print_special_and_balk_p */
5998 /* Possibly print a replacement or prefix.  Return 1 if we should now
5999    skip printing sexp (Because it's shared), 0 otherwise. */
6000 static int
6001 k_print_special_and_balk_p
6002 (klink * sc, pko tracker, pko lookup_env, pko sexp)
6003 {
6004   WITH_REPORTER(0);
6005   /* If this object is directly known to printer, print its symbol. */
6006   if(lookup_env != K_NIL)
6007     {
6008       pko slot = reverse_find_slot_in_env_aux(lookup_env,sexp);
6009       if(slot)
6010         {
6011           putstr (sc, "#,");    /* Reader is to convert the symbol */
6012           printatom (sc, car(slot));
6013           return 1;
6014         }
6015     }
6016   if(tracker == K_NIL)
6017     { return 0; }
6018
6019   /* $$IMPROVE ME Parameterize this and share that parameterization
6020      with get_recurrences */
6021   switch(_get_type(sexp))
6022     {
6023     case T_SYMBOL:
6024     case T_NUMBER:
6025       return 0;
6026     default:
6027       break;
6028     }
6029
6030   WITH_PSYC_UNBOXED(kt_recur_tracker,tracker, T_RECUR_TRACKER, sc);
6031   int index = objtable_get_index(pdata->objs,pdata->table_size,sexp);
6032   if(index < 0) { return 0; }
6033   recur_entry * slot = &pdata->entries[index];
6034   if(slot->count <= 1) { return 0; }
6035
6036   if(slot->seen_in_walk)
6037     {
6038       char *p = sc->strbuff;
6039       snprintf (p, STRBUFFSIZE, "#%d", slot->index_in_walk);
6040       putchars (sc, p, strlen (p));
6041       return 1;         /* Skip printing the object */
6042     }
6043   else
6044     {
6045       slot->seen_in_walk = 1;
6046       slot->index_in_walk = pdata->current_index;
6047       pdata->current_index++;
6048       char *p = sc->strbuff;
6049       snprintf (p, STRBUFFSIZE, "#%d=", slot->index_in_walk);
6050       putchars (sc, p, strlen (p));
6051       return 0;         /* Still should print the object */
6052     }
6053 }
6054 /*_     , kernel_print_sexp_aux */
6055 SIG_CHKARRAY(kernel_print_sexp_aux) =
6056 { K_ANY, REF_OPER(is_recur_tracker), REF_OPER(is_environment), };
6057 static
6058 DEF_SIMPLE_CFUNC (ps0a3, kernel_print_sexp_aux,0)
6059 {
6060   WITH_3_ARGS(sexp, recur_tracker, lookup_env);
6061   WITH_REPORTER(0);
6062   if(k_print_special_and_balk_p(sc, recur_tracker, lookup_env, sexp))
6063     { return K_INERT; }
6064   if (is_vector (sexp))
6065     {
6066       putstr (sc, "#(");
6067       CONTIN_4 (dcrry_4dotALL, kernel_print_vec_from, sc, sexp,
6068                 mk_integer (0), recur_tracker, lookup_env);
6069       return K_INERT;
6070     }
6071   else if (!is_pair (sexp))
6072     {
6073       printatom (sc, sexp);
6074       return K_INERT;
6075     }
6076   /* $$FIX ME Recognize quote etc.
6077
6078      That is hard since the quote operative is not currently defined
6079      as such and we no longer have syntax.
6080    */
6081   else if (car (sexp) == sc->QUOTE && ok_abbrev (cdr (sexp)))
6082     {
6083       putstr (sc, "'");
6084       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
6085     }
6086   else if (car (sexp) == sc->QQUOTE && ok_abbrev (cdr (sexp)))
6087     {
6088       putstr (sc, "`");
6089       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
6090     }
6091   else if (car (sexp) == sc->UNQUOTE && ok_abbrev (cdr (sexp)))
6092     {
6093       putstr (sc, ",");
6094       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
6095     }
6096   else if (car (sexp) == sc->UNQUOTESP && ok_abbrev (cdr (sexp)))
6097     {
6098       putstr (sc, ",@");
6099       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
6100     }
6101   else
6102     {
6103       putstr (sc, "(");
6104       CONTIN_0_RAW(REF_OBJ(k_print_terminate_list), sc);
6105       CONTIN_3 (dcrry_2dotALL, kernel_print_list, sc, cdr (sexp), recur_tracker, lookup_env);
6106       return kernel_print_sexp_aux (sc, car (sexp), recur_tracker, lookup_env);
6107     }
6108 }
6109 /*_     , print_value */
6110 DEF_BOXED_CURRIED(print_value,
6111                   dcrry_1VLL,
6112                   REF_KEY(K_NIL),
6113                   REF_OPER (kernel_print_sexp));
6114 /*_    . k_print_string */
6115 SIG_CHKARRAY(k_print_string) = { REF_OPER(is_string), };
6116 static
6117 DEF_SIMPLE_CFUNC (ps0a1, k_print_string,T_NO_K)
6118 {
6119   WITH_1_ARGS(str);
6120   putstr (sc, string_value(str));
6121   return K_INERT;
6122 }
6123 /*_    . k_print_terminate_list */
6124 /* $$RETHINK ME  This may be the long way to do it. */
6125 static
6126 BOX_OF(kt_string) _k_string_rpar =
6127 { T_STRING | T_IMMUTABLE,
6128   { ")", sizeof(")"), },
6129 };
6130 static
6131 BOX_OF(kt_vec2) _k_list_string_rpar =
6132 { T_PAIR | T_IMMUTABLE,
6133   { REF_OBJ(_k_string_rpar), REF_KEY(K_NIL)}
6134 };
6135 static
6136 DEF_BOXED_CURRIED(k_print_terminate_list,
6137                   dcrry_1dotALL,
6138                   REF_OBJ(_k_list_string_rpar),
6139                   REF_OPER(k_print_string));
6140 /*_    . k_newline */
6141 RGSTR(ground, "newline", REF_OBJ(k_newline))
6142 static
6143 BOX_OF(kt_string) _k_string_newline =
6144 { T_STRING | T_IMMUTABLE,
6145   { "\n", sizeof("\n"), }, };
6146 static
6147 BOX_OF(kt_vec2) _k_list_string_newline =
6148 { T_PAIR | T_IMMUTABLE,
6149   { REF_OBJ(_k_string_newline), REF_KEY(K_NIL)}
6150 };
6151 static
6152 DEF_BOXED_CURRIED(k_newline,
6153                   dcrry_1dotALL,
6154                   REF_OBJ(_k_list_string_newline),
6155                   REF_OPER(k_print_string));
6156
6157 /*_    .  kernel_print_list */
6158 static
6159 DEF_CFUNC (ps0a3, kernel_print_list, REF_DESTR(kernel_print_sexp_aux),0)
6160 {
6161   WITH_REPORTER(0);
6162   WITH_3_ARGS(sexp, recur_tracker, lookup_env);
6163   if(is_pair (sexp))  { putstr (sc, " "); }
6164   else if (sexp != K_NIL) { putstr (sc, " . "); }
6165   else { }
6166
6167   if(k_print_special_and_balk_p(sc, recur_tracker, lookup_env, sexp))
6168     { return K_INERT; }
6169   if (is_pair (sexp))
6170     {
6171       CONTIN_3 (dcrry_3dotALL, kernel_print_list, sc, cdr (sexp), recur_tracker, lookup_env);
6172       return kernel_print_sexp_aux (sc, car (sexp), recur_tracker, lookup_env);
6173     }
6174   if (is_vector (sexp))
6175     {
6176       /* $$RETHINK ME What does this even print? */
6177       CONTIN_3 (dcrry_3dotALL, kernel_print_list, sc, K_NIL, recur_tracker, lookup_env);
6178       return kernel_print_sexp_aux (sc, sexp, recur_tracker, lookup_env);
6179     }
6180
6181   if (sexp != K_NIL)
6182     {
6183       printatom (sc, sexp);
6184     }
6185   return K_INERT;
6186 }
6187
6188
6189 /*_    .  kernel_print_vec_from */
6190 SIG_CHKARRAY(kernel_print_vec_from) =
6191 { K_ANY,
6192   REF_OPER(is_integer),
6193   REF_OPER(is_recur_tracker),
6194   REF_OPER(is_environment), };
6195 DEF_SIMPLE_CFUNC (ps0a4, kernel_print_vec_from,0)
6196 {
6197   WITH_4_ARGS(vec,k_i, recur_tracker, lookup_env);
6198   int i = ivalue (k_i);
6199   int len = vector_len (vec);
6200   if (i == len)
6201     {
6202       putstr (sc, ")");
6203       return K_INERT;
6204     }
6205   else
6206     {
6207       pko elem = vector_elem (vec, i);
6208       set_ivalue (k_i, i + 1);
6209       CONTIN_4 (dcrry_4dotALL, kernel_print_vec_from, sc, vec, arg2, recur_tracker, lookup_env);
6210       putstr (sc, " ");
6211       return kernel_print_sexp_aux (sc, elem, recur_tracker, lookup_env);
6212     }
6213 }
6214 /*_   , Kernel entry points */
6215 /*_    . write */
6216 DEF_APPLICATIVE_W_DESTR(ps0a1,k_write,K_ANY_SINGLETON,0,ground, "write")
6217 {
6218   WITH_1_ARGS(p);
6219   klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
6220   return kernel_print_sexp(sc,p,K_INERT);
6221 }
6222
6223 /*_    . display */
6224 DEF_APPLICATIVE_W_DESTR(ps0a1,k_display,K_ANY_SINGLETON,0,ground, "display")
6225 {
6226   WITH_1_ARGS(p);
6227   klink_push_dyn_binding(sc,K_PRINT_FLAG,K_F);
6228   return kernel_print_sexp(sc,p,K_INERT);
6229 }
6230
6231 /*_   , Tracing */
6232 /*_    . tracing_say */
6233 /* $$TRANSITIONAL  Until we have actual trace hook */
6234 SIG_CHKARRAY(tracing_say) = { REF_OPER(is_string),  K_ANY, };
6235 DEF_SIMPLE_CFUNC (ps0a2, tracing_say,T_NO_K)
6236 {
6237   WITH_2_ARGS(k_string, value);
6238   if (sc->tracing)
6239     {
6240       putstr (sc, string_value(k_string));
6241     }
6242   return value;
6243 }
6244
6245
6246 /*_  . Equivalence */
6247 /*_   , Equivalence of atoms */
6248 SIG_CHKARRAY(eqv) = { K_ANY, K_ANY, };
6249 DEF_SIMPLE_APPLICATIVE(b00a2,eqv,T_NO_K,simple,"equal?/2-atom-atom")
6250 {
6251   WITH_2_ARGS(a,b);
6252
6253   if (is_string (a))
6254     {
6255       if (is_string (b))
6256         {
6257           const char * a_str = string_value (a);
6258           const char * b_str = string_value (b);
6259           if (a_str == b_str) { return 1; }
6260           return !strcmp(a_str, b_str);
6261         }
6262       else
6263         { return (0); }
6264     }
6265   else if (is_number (a))
6266     {
6267       if (is_number (b))
6268         {
6269           if (num_is_integer (a) == num_is_integer (b))
6270             return num_eq (nvalue (a), nvalue (b));
6271         }
6272       return (0);
6273     }
6274   else if (is_character (a))
6275     {
6276       if (is_character (b))
6277         return charvalue (a) == charvalue (b);
6278       else
6279         return (0);
6280     }
6281   else if (is_port (a))
6282     {
6283       if (is_port (b))
6284         return a == b;
6285       else
6286         return (0);
6287     }
6288   else
6289     {
6290       return (a == b);
6291     }
6292 }
6293 /*_   , Equivalence of containers */
6294
6295 /*_  . Hash function */
6296 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
6297
6298 static int
6299 hash_fn (const char *key, int table_size)
6300 {
6301   unsigned int hashed = 0;
6302   const char *c;
6303   int bits_per_int = sizeof (unsigned int) * 8;
6304
6305   for (c = key; *c; c++)
6306     {
6307       /* letters have about 5 bits in them */
6308       hashed = (hashed << 5) | (hashed >> (bits_per_int - 5));
6309       hashed ^= *c;
6310     }
6311   return hashed % table_size;
6312 }
6313 #endif
6314
6315 /* Quick and dirty hash function for pointers */
6316 static int
6317 ptr_hash_fn(void * ptr, int table_size)
6318 { return (long)ptr % table_size; }
6319
6320 /*_  . binder/accessor maker */
6321 pko make_keyed_variable(pko gen_binder, pko gen_accessor)
6322 {
6323   /* Make a unique key object */
6324   pko key = mk_void();
6325   pko binder = wrap (mk_curried
6326                          (dcrry_3A01dotVLL,
6327                           LIST1(key),
6328                           gen_binder));
6329   pko accessor = wrap (mk_curried
6330                            (dcrry_1A01,
6331                             LIST1(key),
6332                             gen_accessor));
6333   /* Curry and wrap the two things. */
6334   return LIST2 (binder, accessor);
6335 }
6336
6337 /*_  . Environment implementation */
6338 /*_   , New-style environment objects */
6339
6340 /*_    . Types */
6341
6342 /*   T_ENV_FRAME is a vec2 used as a pair in the env tree.  It
6343      indicates a frame boundary.
6344 */
6345 /*   T_ENV_PAIR is another vec2 used as a pair in the env tree.  It
6346      indicates no frame boundary.
6347 */
6348
6349 /* Other types are (hackishly) still shared with the vanilla types:
6350
6351    A vector is interpeted as a hash table vector that is "as if" it
6352    were a list of T_ENV_PAIR.  Each element is an alist of bindings.
6353    It can only hold symbol bindings, not keyed bindings, because we
6354    can't hash keyed bindings.
6355
6356    A pair is interpreted as a binding of something and value.  That
6357    something can be either a symbol or a key (void object).  It is
6358    held directly by an T_ENV_FRAME or T_ENV_PAIR (or "as if", by the
6359    alists of a hash table vector).
6360
6361  */
6362
6363 /*_    . Object functions */
6364
6365 DEF_T_PRED (is_environment, T_ENV_FRAME,ground,"environment?/o1");
6366
6367 /*_   , New environment implementation */
6368
6369 #ifndef USE_ALIST_ENV
6370 static pko
6371 find_slot_in_env_vector (pko eobj, pko hdl)
6372 {
6373   for (; eobj != K_NIL; eobj = unsafe_v2cdr (eobj))
6374     {
6375       assert (is_pair (eobj));
6376       pko slot = unsafe_v2car (eobj);
6377       assert (is_pair (slot));
6378       if (unsafe_v2car (slot) == hdl)
6379         {
6380           return slot;
6381         }
6382     }
6383   return 0;
6384 }
6385
6386 static pko
6387 reverse_find_slot_in_env_vector (pko eobj, pko value)
6388 {
6389   for (; eobj != K_NIL; eobj = unsafe_v2cdr (eobj))
6390     {
6391       assert (is_pair (eobj));
6392       pko slot = unsafe_v2car (eobj);
6393       assert (is_pair (slot));
6394       if (unsafe_v2cdr (slot) == value)
6395         {
6396           return slot;
6397         }
6398     }
6399   return 0;
6400 }
6401 #endif
6402
6403 /*
6404  * If we're using vectors, each frame of the environment may be a hash
6405  * table: a vector of alists hashed by variable name.  In practice, we
6406  * use a vector only for the initial frame; subsequent frames are too
6407  * small and transient for the lookup speed to out-weigh the cost of
6408  * making a new vector.
6409  */
6410 static INLINE pko
6411 make_new_frame(pko old_env)
6412 {
6413   pko new_frame;
6414 #ifndef USE_ALIST_ENV
6415   /* $$IMPROVE ME  Make a better test for whether to make vector. */
6416   /* The interaction-environment has about 300 variables in it. */
6417   if (old_env == K_NIL)
6418     {
6419       new_frame = mk_vector (461, K_NIL);
6420     }
6421   else
6422 #endif
6423     {
6424       new_frame = K_NIL;
6425     }
6426
6427   return v2cons (T_ENV_FRAME, new_frame, old_env);
6428 }
6429
6430 static INLINE void
6431 new_slot_spec_in_env (pko env, pko variable, pko value)
6432 {
6433   assert(is_environment(env));
6434   assert(is_symbol(variable));
6435   pko slot = mcons (variable, value);
6436   pko car_env = unsafe_v2car (env);
6437 #ifndef USE_ALIST_ENV
6438   if (is_vector (car_env))
6439     {
6440       int location = hash_fn (symname (0,variable), vector_len (car_env));
6441
6442       set_vector_elem (car_env, location,
6443                        cons (slot,
6444                              vector_elem (car_env, location)));
6445     }
6446   else
6447 #endif
6448     {
6449       pko new_list = v2cons (T_ENV_PAIR, slot, car_env);
6450       unsafe_v2set_car (env, new_list);
6451     }
6452 }
6453
6454 enum env_frame_search_restriction
6455 {
6456   env_fsr_all,
6457   env_fsr_only_coming_frame,
6458   env_fsr_only_this_frame,
6459 };
6460
6461 /* This explores a tree of bindings, punctuated by frames past which
6462    we sometimes don't search. */
6463 static pko
6464 find_slot_in_env_aux (pko eobj, pko hdl, int restr)
6465 {
6466   if(eobj == K_NIL)
6467     { return 0; }
6468   _kt_tag type = _get_type (eobj);
6469   switch(type)
6470     {
6471       /* We have a slot (Which for now is just a pair) */
6472     case T_PAIR:
6473       if(unsafe_v2car (eobj) == hdl)
6474         { return eobj; }
6475       else
6476         { return 0; }
6477 #ifndef USE_ALIST_ENV
6478     case T_VECTOR:
6479       {
6480         /* Only for symbols. */
6481         if(!is_symbol (hdl)) { return 0; }
6482         int location = hash_fn (symname (0,hdl), vector_len (eobj));
6483         pko el = vector_elem (eobj, location);
6484         return find_slot_in_env_vector (el, hdl);
6485       }
6486 #endif
6487       /* We have some sort of env pair */
6488     case T_ENV_FRAME:
6489       /* Check whether we should keep looking. */
6490       switch(restr)
6491         {
6492         case env_fsr_all:
6493           break;
6494         case env_fsr_only_coming_frame:
6495           restr = env_fsr_only_this_frame;
6496           break;
6497         case env_fsr_only_this_frame:
6498           return 0;
6499         default:
6500           errx (3,
6501                "find_slot_in_env_aux: Bad restriction enum: %d", restr);
6502         }
6503       /* Fallthru */
6504     case T_ENV_PAIR:
6505       {
6506         /* Explore car before cdr */
6507         pko found = find_slot_in_env_aux (unsafe_v2car (eobj), hdl, restr);
6508         if(found) { return found; }
6509         return find_slot_in_env_aux (unsafe_v2cdr (eobj),hdl,restr);
6510       }
6511     default:
6512       /* No other type should be found */
6513       errx (3,
6514            "find_slot_in_env_aux: Bad type: %d", type);
6515       return 0;                 /* NOTREACHED */
6516     }
6517 }
6518
6519 static pko
6520 find_slot_in_env (pko env, pko hdl, int all)
6521 {
6522   assert(is_environment(env));
6523   enum env_frame_search_restriction restr =
6524     all ? env_fsr_all : env_fsr_only_coming_frame;
6525   return find_slot_in_env_aux(env,hdl,restr);
6526 }
6527 /*_   , Reverse find-slot */
6528 /*_    . env_confirm_slot */
6529 static int
6530 env_confirm_slot(pko env, pko slot)
6531 {
6532   assert(is_pair(slot));
6533   return
6534     (find_slot_in_env_aux(env,unsafe_v2car(slot),env_fsr_all) == slot);
6535 }
6536 /*_    . reverse_find_slot_in_env_aux2 */
6537 static pko
6538 reverse_find_slot_in_env_aux2(pko env, pko eobj, pko value)
6539 {
6540   if(eobj == K_NIL)
6541     { return 0; }
6542   _kt_tag type = _get_type (eobj);
6543   switch(type)
6544     {
6545       /* We have a slot (Which for now is just a pair) */
6546     case T_PAIR:
6547       if((unsafe_v2cdr (eobj) == value)
6548          && env_confirm_slot(env, eobj))
6549         { return eobj; }
6550       else
6551         { return 0; }
6552 #ifndef USE_ALIST_ENV
6553     case T_VECTOR:
6554       {
6555         /* $$IMPROVE ME Create a reverse-lookup vector if we come here
6556            and there is none.  */
6557         int i;
6558         for(i = 0; i < vector_len (eobj); ++i)
6559           {
6560             pko slot = reverse_find_slot_in_env_vector(vector_elem (eobj, i), value);
6561             if(slot &&
6562                env_confirm_slot(env, slot))
6563               { return slot; }
6564           }
6565         return 0;
6566       }
6567 #endif
6568       /* We have some sort of env pair */
6569     case T_ENV_FRAME:
6570       /* Fallthru */
6571     case T_ENV_PAIR:
6572       {
6573         /* Explore car before cdr */
6574         pko found =
6575           reverse_find_slot_in_env_aux2 (env, unsafe_v2car (eobj), value);
6576         if(found && env_confirm_slot(env, found))
6577           { return found; }
6578         found =
6579           reverse_find_slot_in_env_aux2 (env, unsafe_v2cdr (eobj), value);
6580         if(found && env_confirm_slot(env, found))
6581           { return found; }
6582         return 0;
6583       }
6584     default:
6585       /* No other type should be found */
6586       errx (3,
6587            "reverse_find_slot_in_env_aux2: Bad type: %d", type);
6588       return 0;                 /* NOTREACHED */
6589     }
6590 }
6591
6592 /*_    . reverse_find_slot_in_env_aux */
6593 static pko
6594 reverse_find_slot_in_env_aux (pko env, pko value)
6595 {
6596   assert(is_environment(env));
6597   return reverse_find_slot_in_env_aux2(env, env, value);
6598 }
6599
6600 /*_    . Entry point */
6601 /* Exposed for testing */
6602 /* NB, args are in different order than in the helpers */
6603 SIG_CHKARRAY(reverse_find_slot_in_env) =
6604 { K_ANY, REF_OPER(is_environment), };
6605 DEF_SIMPLE_APPLICATIVE (ps0a2, reverse_find_slot_in_env,T_NO_K,unsafe, "reverse-lookup")
6606 {
6607   WITH_2_ARGS(value,env);
6608   WITH_REPORTER(0);
6609   pko slot = reverse_find_slot_in_env_aux(env, value);
6610   if(slot) { return car(slot); }
6611   else
6612     {
6613       KERNEL_ERROR_0(sc, "reverse_find_slot_in_env: No match");
6614     }
6615 }
6616
6617 /*_    . reverse-binds?/2 */
6618 /* $$IMPROVE ME  Maybe combine these */
6619 DEF_APPLICATIVE_W_DESTR(b00a2,reverse_binds_p,
6620                         REF_DESTR(reverse_find_slot_in_env),
6621                         T_NO_K,simple,"reverse-binds?/2")
6622 {
6623   WITH_2_ARGS(value,env);
6624   return reverse_find_slot_in_env_aux(env, value) ? 1 : 0;
6625 }
6626 /*_   , Shared functions */
6627
6628 static INLINE void
6629 new_frame_in_env (klink * sc, pko old_env)
6630 {
6631   sc->envir = make_new_frame (old_env);
6632 }
6633
6634 static INLINE void
6635 set_slot_in_env (pko slot, pko value)
6636 {
6637   assert (is_pair (slot));
6638   set_cdr (0, slot, value);
6639 }
6640
6641 static INLINE pko
6642 slot_value_in_env (pko slot)
6643 {
6644   WITH_REPORTER(0);
6645   assert (is_pair (slot));
6646   return cdr (slot);
6647 }
6648
6649 /*_   , Keyed static bindings */
6650 /*_    . Support */
6651 /*_     , Making them */
6652 /* Make a new frame containing just the one keyed static variable. */
6653 static INLINE pko
6654 env_plus_keyed_var (pko key, pko value, pko old_env)
6655 {
6656   pko slot = cons (key, value);
6657   return v2cons (T_ENV_FRAME, slot, old_env);
6658 }
6659 /*_     , Finding them */
6660 /* find_slot_in_env works for this too. */
6661 /*_    . Interface */
6662 /*_     , Binder */
6663 SIG_CHKARRAY(klink_ksb_binder) =
6664 { REF_OPER(is_key),  K_ANY, REF_OPER(is_environment), };
6665 DEF_SIMPLE_CFUNC(ps0a3,klink_ksb_binder,T_NO_K)
6666 {
6667   WITH_3_ARGS(key, value, env);
6668   /* Check that env is in fact a environment. */
6669   if(!is_environment(env))
6670     {
6671       KERNEL_ERROR_1(sc,
6672                      "klink_ksb_binder: Arg 2 must be an environment: ",
6673                      env);
6674     }
6675   /* Return a new environment with just that binding. */
6676   return env_plus_keyed_var(key, value, env);
6677 }
6678
6679 /*_     , Accessor */
6680 SIG_CHKARRAY(klink_ksb_accessor) =
6681 { REF_OPER(is_key), };
6682 DEF_SIMPLE_CFUNC(ps0a1,klink_ksb_accessor,T_NO_K)
6683 {
6684   WITH_1_ARGS(key);
6685   pko value = find_slot_in_env(sc->envir,key,1);
6686   if(!value)
6687     {
6688       KERNEL_ERROR_0(sc, "klink_ksb_accessor: No binding found");
6689     }
6690
6691   return slot_value_in_env (value);
6692 }
6693
6694 /*_     , make_keyed_static_variable */
6695 RGSTR(ground, "make-keyed-static-variable", REF_OPER(make_keyed_static_variable))
6696 DEF_CFUNC(p00a0, make_keyed_static_variable,K_NO_TYPE,T_NO_K)
6697 {
6698   return make_keyed_variable(
6699                              REF_OPER(klink_ksb_binder),
6700                              REF_OPER (klink_ksb_accessor));
6701 }
6702 /*_   , Building environments */
6703 /* Argobject is checked internally, so K_ANY */
6704 DEF_APPLICATIVE_W_DESTR(ps0a1,make_environment,K_ANY,T_NO_K,ground, "make-environment")
6705 {
6706   WITH_1_ARGS(parents);
6707   /* $$IMPROVE ME Factor this so we only call get_list_metrics_aux
6708      once on this object. */
6709   int4 metrics;
6710   get_list_metrics_aux(parents, metrics);
6711   pko typecheck = REF_OPER(is_environment);
6712   /* This will reject dotted lists */
6713   if(!typecheck_repeat(sc,parents,&typecheck,1,1))
6714     {
6715       KERNEL_ERROR_0 (sc, "make_environment: argobject must be a list of environments");
6716     }
6717
6718   /* Collect the parent environments. */
6719   int i;
6720   pko rv_par_list = K_NIL;
6721   for(i = 0; i < metrics[lm_num_pairs]; ++i, parents = pair_cdr(0, parents))
6722     {
6723       pko pare = pair_car(0, parents);
6724       rv_par_list = v2cons (T_ENV_PAIR, pare, rv_par_list);
6725     }
6726
6727   /* Reverse the list in place. */
6728   pko par_list;
6729
6730   par_list = unsafe_v2reverse_in_place(K_NIL, rv_par_list);
6731
6732   /* $$IMPROVE ME Check for redundant environments and skip them.
6733      Check only *previous* environments, because we still need to
6734      search correctly.  When recurrences walks environments too, we
6735      can use that to find them. */
6736   /* $$IMPROVE ME Add to environment information to block rechecks. */
6737
6738   /* Return a new environment with all of those as parents. */
6739   return make_new_frame(par_list);
6740 }
6741 /*_   , bindsp_1 */
6742 RGSTR(simple,"$binds?/2", REF_OPER(bindsp_1))
6743 SIG_CHKARRAY(bindsp_1) =
6744 { REF_OPER(is_environment), REF_OPER(is_symbol), };
6745 DEF_SIMPLE_CFUNC(bs0a2,bindsp_1,T_NO_K)
6746 {
6747   WITH_2_ARGS(env, sym);
6748   return find_slot_in_env(env, sym, 1) ? 1 : 0;
6749 }
6750 /*_   , find-binding */
6751 DEF_APPLICATIVE_W_DESTR(ps0a2,find_binding,REF_DESTR(bindsp_1),T_NO_K,ground,"find-binding")
6752 {
6753   WITH_2_ARGS(env, sym);
6754   pko binding = find_slot_in_env(env, sym, 1);
6755   if(binding)
6756     {
6757       return cons(K_T,slot_value_in_env (binding));
6758     }
6759   else
6760     {
6761       return cons(K_F,K_INERT);
6762     }
6763 }
6764
6765 /*_  . Stack */
6766 /*_   , Enumerations */
6767 enum klink_stack_cell_types
6768 {
6769   ksct_invalid,
6770   ksct_frame,
6771   ksct_binding,
6772   ksct_entry_guards,
6773   ksct_exit_guards,
6774   ksct_profile,
6775   ksct_args,
6776   ksct_arg_barrier,             /* Barrier to propagating pseudo-env. */
6777 };
6778 /*_   , Structs */
6779
6780 struct dump_stack_frame
6781 {
6782   pko envir;
6783   pko ff;
6784 };
6785 struct stack_binding
6786 {
6787   pko key;
6788   pko value;
6789 };
6790
6791 struct stack_guards
6792 {
6793   pko guards;
6794   pko envir;
6795 };
6796
6797 struct stack_profiling
6798 {
6799   pko ff;
6800   int initial_count;
6801   int returned_p;
6802 };
6803
6804 struct stack_arg
6805 {
6806   pko vec;
6807   int frame_depth;
6808 };
6809
6810 typedef struct dump_stack_frame_cell
6811 {
6812   enum klink_stack_cell_types type;
6813   _kt_spagstack next;
6814   union
6815   {
6816     struct dump_stack_frame frame;
6817     struct stack_binding    binding;
6818     struct stack_guards     guards;
6819     struct stack_profiling  profiling;
6820     struct stack_arg        pseudoenv;
6821   } data;
6822 } dump_stack_frame_cell;
6823
6824 /*_   , Initialize */
6825
6826 static INLINE void
6827 dump_stack_initialize (klink * sc)
6828 {
6829   sc->dump = 0;
6830 }
6831
6832 static INLINE int
6833 stack_empty (klink * sc)
6834 { return sc->dump == 0; }
6835
6836 /*_   , Frames */
6837 static int
6838 klink_pop_cont (klink * sc)
6839 {
6840   _kt_spagstack rv_pseudoenvs = 0;
6841
6842   /* Always return frame, which sc->dump will be set to. */
6843   /* for(frame = sc->dump; frame != 0; frame = frame->next) */
6844   while(1)
6845     {
6846       if (sc->dump == 0)
6847         {
6848           return 0;
6849         }
6850       else
6851         {
6852           const _kt_spagstack frame = sc->dump;
6853           if(frame->type == ksct_frame)
6854             {
6855               const struct dump_stack_frame *pdata = &frame->data.frame;
6856               sc->next_func    = pdata->ff;
6857               sc->envir        = pdata->envir;
6858
6859               _kt_spagstack final_frame = frame->next;
6860
6861               /* Add the collected pseudo-env elements */
6862               while(rv_pseudoenvs)
6863                 {
6864                   _kt_spagstack el = rv_pseudoenvs;
6865                   _kt_spagstack new_top = rv_pseudoenvs->next;
6866                   el->next = final_frame;
6867                   final_frame = el;
6868                   rv_pseudoenvs = new_top;
6869                 }
6870               sc->dump = final_frame;
6871               return 1;
6872             }
6873 #ifdef PROFILING
6874           else
6875           if(frame->type == ksct_profile)
6876             {
6877               struct stack_profiling * pdata = &frame->data.profiling;
6878               k_profiling_done_frame(sc,pdata);
6879               sc->dump = frame->next;
6880             }
6881 #endif
6882           else if( frame->type == ksct_args )
6883             {
6884               struct stack_arg * old_pe = &frame->data.pseudoenv;
6885               if(old_pe->frame_depth > 0)
6886                 {
6887                   /* Make a copy, to be re-added lower down */
6888                   _kt_spagstack new_pseudoenv =
6889                     (_kt_spagstack)
6890                     GC_MALLOC (sizeof (dump_stack_frame_cell));
6891                   struct stack_arg * new_pe = &new_pseudoenv->data.pseudoenv;
6892                   new_pe->vec         = old_pe->vec;
6893                   new_pe->frame_depth = old_pe->frame_depth - 1;
6894
6895                   new_pseudoenv->type = ksct_args;
6896                   new_pseudoenv->next = rv_pseudoenvs;
6897                   rv_pseudoenvs = new_pseudoenv;
6898                 }
6899
6900               sc->dump = frame->next;
6901             }
6902           else if( frame->type == ksct_arg_barrier )
6903             {
6904               errx( 0, "Not allowed");
6905               rv_pseudoenvs = 0;
6906               sc->dump = frame->next;
6907             }
6908           else
6909             {
6910               sc->dump = frame->next;
6911             }
6912         }
6913     }
6914 }
6915
6916 static _kt_spagstack
6917 klink_push_cont_aux
6918 (_kt_spagstack old_frame, pko ff, pko env)
6919 {
6920   _kt_spagstack frame =
6921     (_kt_spagstack)
6922     GC_MALLOC (sizeof (dump_stack_frame_cell));
6923   struct dump_stack_frame * pdata = &frame->data.frame;
6924   pdata->ff           = ff;
6925   pdata->envir        = env;
6926
6927   frame->type = ksct_frame;
6928   frame->next = old_frame;
6929   return frame;
6930 }
6931
6932 /* $$MOVE ME */
6933 static void
6934 klink_push_cont (klink * sc, pko ff)
6935 { sc->dump = klink_push_cont_aux(sc->dump, ff, sc->envir); }
6936
6937 /*_   , Dynamic bindings */
6938
6939 /* We do not pop dynamic bindings, only frames. */
6940 /* We deal with dynamic bindings in the context of the interpreter so
6941    that in the future we can cache them. */
6942 static void
6943 klink_push_dyn_binding (klink * sc, pko key, pko value)
6944 {
6945   _kt_spagstack frame =
6946     (_kt_spagstack)
6947     GC_MALLOC (sizeof (dump_stack_frame_cell));
6948   struct stack_binding *pdata = &frame->data.binding;
6949
6950   pdata->key           = key;
6951   pdata->value        = value;
6952
6953   frame->type = ksct_binding;
6954   frame->next = sc->dump;
6955   sc->dump = frame;
6956 }
6957
6958
6959 static pko
6960 klink_find_dyn_binding(klink * sc, pko key)
6961 {
6962   _kt_spagstack frame = sc->dump;
6963   while(1)
6964     {
6965       if (frame == 0)
6966         {
6967           return 0;
6968         }
6969       else
6970         {
6971           if(frame->type == ksct_binding)
6972             {
6973               const struct stack_binding *pdata = &frame->data.binding;
6974               if(pdata->key == key)
6975                 { return pdata->value; }
6976             }
6977           frame = frame->next;
6978         }
6979     }
6980 }
6981 /*_   , Guards */
6982 /*_    . klink_push_guards */
6983 static _kt_spagstack
6984 klink_push_guards
6985 (_kt_spagstack old_frame, pko guards, pko envir, int exit)
6986 {
6987   _kt_spagstack frame =
6988     (_kt_spagstack)
6989     GC_MALLOC (sizeof (dump_stack_frame_cell));
6990   struct stack_guards * pdata = &frame->data.guards;
6991   pdata->guards = guards;
6992   pdata->envir  = envir;
6993
6994   frame->type = exit ? ksct_exit_guards : ksct_entry_guards;
6995   frame->next = old_frame;
6996   return frame;
6997 }
6998 /*_    . get_guards_lo1st */
6999 /* Get a list of guard entries, root-most on top. */
7000 static pko
7001 get_guards_lo1st(_kt_spagstack frame)
7002 {
7003   pko list = K_NIL;
7004   for(; frame != 0; frame = frame->next)
7005     {
7006       if((frame->type == ksct_entry_guards) ||
7007          (frame->type == ksct_exit_guards))
7008         {
7009           list = cons(mk_continuation(frame), list);
7010         }
7011     }
7012
7013   return list;
7014 }
7015 /*_   , Args */
7016 /*_    . Misc */
7017 /*_     , set_nth_arg */
7018 #if 0
7019 /* Set the nth arg */
7020 /* Unused, probably for a while, probably will never be used in this
7021    form. */
7022 int
7023 set_nth_arg(klink * sc, int n, pko value)
7024 {
7025   _kt_spagstack frame = sc->dump;
7026   int i = 0;
7027   for(frame = sc->dump; frame != 0; frame = frame->next)
7028     {
7029       if(frame->type == ksct_args)
7030         {
7031           if( i == n )
7032             {
7033               frame->data.arg = value;
7034               return 1;
7035             }
7036           else
7037             { i++; }
7038         }
7039     }
7040   /* If we got here we never encountered the target. */
7041   return 0;
7042 }
7043 #endif
7044 /*_    . Store from value */
7045 /*_     , push_arg_raw */
7046 _kt_spagstack
7047 push_arg_raw(_kt_spagstack old_frame, pko value, int frame_depth)
7048 {
7049   _kt_spagstack frame =
7050     (_kt_spagstack)
7051     GC_MALLOC (sizeof (dump_stack_frame_cell));
7052
7053   frame->data.pseudoenv.vec = value;
7054   frame->data.pseudoenv.frame_depth = frame_depth;
7055   frame->type = ksct_args;
7056   frame->next = old_frame;
7057   return frame;
7058 }
7059 /*_     , k_do_store */
7060 /* T_STORE */
7061 pko
7062 k_do_store(klink * sc, pko functor, pko value)
7063 {
7064   WITH_PSYC_UNBOXED( kt_opstore, functor, T_STORE, sc );
7065   /* $$MAKE ME SAFE do_destructure must be safe vs resuming.  Error if
7066      not T_NO_K.  Don't try to maybe resume, because so far we never
7067      have to do that.
7068    */
7069   pko vec = do_destructure( sc, value, pdata->destr );
7070   /* Push that as arg */
7071   sc->dump = push_arg_raw (sc->dump, vec, pdata->frame_depth);
7072   return K_INERT;
7073 }
7074 /*_    . Load to value */
7075 /*_     , get_nth_arg */
7076 pko
7077 get_nth_arg( _kt_spagstack frame, int n )
7078 {
7079   int i = 0;
7080   for(; frame != 0; frame = frame->next)
7081     {
7082       if(frame->type == ksct_args)
7083         {
7084           if( i == n )
7085             { return frame->data.pseudoenv.vec; }
7086           else
7087             { i++; }
7088         }
7089     }
7090   /* If we got here we never encountered the target. */
7091   return 0;
7092 }
7093
7094 /*_     , k_load_recurse */
7095 /* $$IMPROVE ME Add a shortcut for accessing value without ever
7096    storing it. */
7097 pko
7098 k_load_recurse( _kt_spagstack frame, pko tree )
7099 {
7100   if(_get_type( tree) == T_PAIR)
7101     {
7102       WITH_PSYC_UNBOXED( kt_vec2, tree, T_PAIR, 0 );
7103       if( is_integer( pdata->_car ) && is_integer( pdata->_cdr ))
7104         {
7105           /* Pair of integers: Look up that item, look up secondary
7106              index, return it */
7107           const int n = ivalue( pdata->_car );
7108           const int m = ivalue( pdata->_cdr );
7109           pko vec = get_nth_arg( frame, n );
7110           assert( vec );
7111           assert( is_vector( vec ));
7112           pko value = basvector_elem( vec, m );
7113           assert( value );
7114           return value;
7115         }
7116       else
7117         {
7118           /* Pair, not integers: Explore car and cdr, return cons of them. */
7119           return cons(
7120                       k_load_recurse( frame, pdata->_car ),
7121                       k_load_recurse( frame, pdata->_cdr ));
7122         }
7123     }
7124   else
7125     {
7126       /* Anything else: Return it literally. */
7127       return tree;
7128     }
7129 }
7130
7131 /*_     , k_do_load */
7132 /* T_LOAD C-destructures as a singleton.  It will contain a tree */
7133 /* This may largely take over for decurriers. */
7134 pko
7135 k_do_load(klink * sc, pko functor, pko value)
7136 {
7137   WITH_PSYC_UNBOXED( pko, functor, T_LOAD, sc );
7138   return k_load_recurse( sc->dump, *pdata );
7139 }
7140
7141 /*_   , Stack ancestry */
7142 /*_    . frame_is_ancestor_of */
7143 int frame_is_ancestor_of(_kt_spagstack frame, _kt_spagstack other)
7144 {
7145   /* Walk from other towards root.  Return 1 if we ever encounter
7146      frame, otherwise 0. */
7147   for(; other != 0; other = other->next)
7148     {
7149       if(other == frame)
7150         { return 1; }
7151     }
7152   return 0;
7153 }
7154 /*_    . special_dynxtnt */
7155 /* Make a child of dynamic extent OUTER that evals with dynamic
7156    environment ENVIR continues normally to PROX_DEST. */
7157 _kt_spagstack special_dynxtnt
7158 (_kt_spagstack outer, _kt_spagstack prox_dest, pko envir)
7159 {
7160   return
7161     klink_push_cont_aux(outer,
7162                         mk_curried(dcrry_2A01VLL,
7163                                    LIST1(mk_continuation(prox_dest)),
7164                                    REF_OPER(invoke_continuation)),
7165                         envir);
7166 }
7167 /*_    . curr_frame_depth */
7168 int curr_frame_depth(_kt_spagstack frame)
7169 {
7170   /* Walk towards root, counting. */
7171   int count = 0;
7172   for(; frame != 0; frame = frame->next, count++)
7173     { }
7174   return count;
7175 }
7176 /*_   , Continuations */
7177 /*_    . Struct */
7178 typedef struct
7179 {
7180   _kt_spagstack frame;
7181 }
7182   continuation_t;
7183
7184 /*_    . Type */
7185 DEF_T_PRED (is_continuation, T_CONTINUATION,ground, "continuation?/o1");
7186 /*_    . Create */
7187 static pko
7188 mk_continuation (_kt_spagstack frame)
7189 {
7190   ALLOC_BOX_PRESUME (continuation_t, T_CONTINUATION);
7191   pdata->frame        = frame;
7192   return PTR2PKO(pbox);
7193 }
7194 /*_    . Parts */
7195 static _kt_spagstack
7196 cont_dump (pko p)
7197 {
7198   WITH_PSYC_UNBOXED(continuation_t,p,T_CONTINUATION,0);
7199   return pdata->frame;
7200 }
7201
7202 /*_    . Continuations WRT interpreter */
7203 /*_     , current_continuation */
7204 static pko
7205 current_continuation (klink * sc)
7206 {
7207   return mk_continuation (sc->dump);
7208 }
7209 /*_    . Operations */
7210 /*_     , invoke_continuation */
7211 /* DOES NOT RETURN */
7212 /* Control is resumed at _klink_cycle */
7213
7214 /* Static and not directly available to Kernel, it's the eventual
7215    target of continuation_to_applicative. */
7216 SIG_CHKARRAY(invoke_continuation) =
7217 { REF_OPER(is_continuation), K_ANY, };
7218 DEF_SIMPLE_CFUNC(vs0a2,invoke_continuation,T_NO_K)
7219 {
7220   WITH_2_ARGS (p, value);
7221   assert(is_continuation(p));
7222   if(p)
7223     { sc->dump = cont_dump (p); }
7224   sc->value = value;
7225   longjmp (sc->pseudocontinuation, 1);
7226 }
7227 /*_     , add_guard */
7228 /* Add the appropriate guard, if any, and return the new proximate
7229    destination. */
7230 _kt_spagstack
7231 add_guard
7232 (_kt_spagstack prox_dest, _kt_spagstack to_contain,
7233  pko guard_list, pko envir, _kt_spagstack outer)
7234 {
7235   WITH_REPORTER(0);
7236   pko x;
7237   for(x = guard_list; x != K_NIL; x = cdr(x))
7238     {
7239       pko selector = car(car(x));
7240       assert(is_continuation(selector));
7241       if(frame_is_ancestor_of(cont_dump(selector), to_contain))
7242         {
7243           /* Call has to take place in the dynamic extent of the
7244              next frame around this set of guards, so that the
7245              interceptor has access to dynamic bindings, but then
7246              control has to continue normally to the next guard or
7247              finally to the destination.
7248
7249              So we extend the next frame with a call to
7250              invoke_continuation, currying the next destination in the
7251              chain.  That does not check guards, so in effect it
7252              continues normally.  Then we extend that with a call to
7253              the interceptor, currying an continuation->applicative of
7254              the guards' outer continuation.
7255
7256              NB, continuation->applicative is correct.  It would be
7257              wrong to shortcircuit it.  Although there are no guards
7258              between there and the outer continuation, the
7259              continuation we pass might be called from another dynamic
7260              context.  But it needs to be unwrapped.
7261           */
7262           pko wrapped_interceptor = cadr(car(x));
7263           assert(is_applicative(wrapped_interceptor));
7264           pko interceptor = unwrap(0,wrapped_interceptor);
7265           assert(is_operative(interceptor));
7266
7267           _kt_spagstack med_frame =
7268             special_dynxtnt(outer, prox_dest, envir);
7269           prox_dest =
7270             klink_push_cont_aux(med_frame,
7271                                 mk_curried(dcrry_2VLLdotALL,
7272                                            LIST1(continuation_to_applicative(mk_continuation(outer))),
7273                                            interceptor),
7274                                 envir);
7275
7276           /* We use only the first match so end the loop. */
7277           break;
7278         }
7279     }
7280   return prox_dest;
7281 }
7282 /*_     , add_guard_chain */
7283 _kt_spagstack
7284 add_guard_chain
7285 (_kt_spagstack prox_dest, pko guard_frame_list, _kt_spagstack to_contain, int exit)
7286 {
7287   WITH_REPORTER(0);
7288   const enum klink_stack_cell_types tag
7289     = exit ? ksct_exit_guards : ksct_entry_guards ;
7290   for( ; guard_frame_list != K_NIL ; guard_frame_list = cdr(guard_frame_list))
7291     {
7292       _kt_spagstack guard_frame = cont_dump(car(guard_frame_list));
7293       if(guard_frame->type == tag)
7294         {
7295           struct stack_guards * pguards = &guard_frame->data.guards;
7296           prox_dest =
7297             add_guard(prox_dest,
7298                       to_contain,
7299                       pguards->guards,
7300                       pguards->envir,
7301                       exit ? guard_frame->next : guard_frame);
7302         }
7303     }
7304   return prox_dest;
7305 }
7306 /*_     , continue_abnormally */
7307 /*** Arrange to "walk" from current continuation to c, passing control
7308      thru appropriate guards.  ***/
7309 SIG_CHKARRAY(continue_abnormally) =
7310 { REF_OPER(is_continuation), K_ANY, };
7311 /* I don't give this T_NO_K even though technically it longjmps
7312    rather than pushing into the eval loop.  In the future we may
7313    distinguish those two cases. */
7314 DEF_SIMPLE_CFUNC(ps0a2,continue_abnormally,0)
7315 {
7316   WITH_2_ARGS(c,value);
7317   WITH_REPORTER(0);
7318   _kt_spagstack source      = sc->dump;
7319   _kt_spagstack destination = cont_dump (c);
7320
7321   /*** Find the guard frames on the intermediate path. ***/
7322
7323   /* Control is exiting our current frame, so collect guards from
7324      there towards root.  What we get is lowest first. */
7325   pko exiting_lo1st = get_guards_lo1st(source);
7326   /* Control is entering c's frame, so collect guards from there
7327      towards root.  Again it's lowest first.  */
7328   pko entering_lo1st = get_guards_lo1st(destination);
7329
7330   /* Remove identical entries from the top, thus removing any merged
7331      part. */
7332   while((exiting_lo1st != K_NIL) &&
7333         (entering_lo1st != K_NIL) &&
7334         (cont_dump(car(exiting_lo1st)) == cont_dump(car(entering_lo1st))))
7335     {
7336       exiting_lo1st  = cdr(exiting_lo1st);
7337       entering_lo1st = cdr(entering_lo1st);
7338     }
7339
7340
7341
7342   /*** Construct a string of calls to the appropriate guards, ending
7343        at destination.  We collect in the reverse of the order that
7344        they will be run, so collect from "entering" first, from
7345        highest to lowest, then collect from "exiting", from lowest to
7346        highest. ***/
7347
7348   _kt_spagstack prox_dest = destination;
7349
7350   pko entering_hi1st = reverse(sc, entering_lo1st);
7351   prox_dest = add_guard_chain(prox_dest, entering_hi1st, destination, 0);
7352   prox_dest = add_guard_chain(prox_dest,  exiting_lo1st, source,      1);
7353
7354   invoke_continuation(sc, mk_continuation(prox_dest), value);
7355   return value;                 /* NOTREACHED */
7356 }
7357
7358 /*_    . Interface */
7359 /*_     , call_cc */
7360 SIG_CHKARRAY(call_cc) = { REF_OPER(is_combiner), };
7361 DEF_SIMPLE_APPLICATIVE(ps0a1,call_cc,0,ground, "call/cc")
7362 {
7363   WITH_1_ARGS(combiner);
7364   pko cc = current_continuation(sc);
7365   return kernel_eval_aux(sc,combiner,LIST1(cc),sc->envir);
7366 }
7367 /*_     , extend-continuation */
7368 /*_      . extend_continuation_aux */
7369 pko
7370 extend_continuation_aux(_kt_spagstack old_frame, pko a, pko env)
7371 {
7372   _kt_spagstack frame = klink_push_cont_aux(old_frame, a, env);
7373   return mk_continuation(frame);
7374 }
7375 /*_      . extend_continuation */
7376 SIG_CHKARRAY(extend_continuation) =
7377 { REF_OPER(is_continuation),
7378   REF_OPER(is_applicative),
7379   REF_KEY(K_TYCH_OPTIONAL),
7380   REF_OPER(is_environment),
7381 };
7382 DEF_SIMPLE_APPLICATIVE(ps0a3, extend_continuation,T_NO_K,ground, "extend-continuation")
7383 {
7384   WITH_3_ARGS(c, a, env);
7385   assert(is_applicative(a));
7386   if(env == K_INERT) { env = make_new_frame(K_NIL); }
7387   return extend_continuation_aux(cont_dump(c), unwrap(sc,a), env);
7388 }
7389 /*_     , continuation->applicative */
7390 SIG_CHKARRAY(continuation_to_applicative) = { REF_OPER(is_continuation), };
7391 DEF_SIMPLE_APPLICATIVE(p00a1,continuation_to_applicative,T_NO_K,ground, "continuation->applicative")
7392 {
7393   WITH_1_ARGS(c);
7394   return
7395     wrap(mk_curried (dcrry_2A01VLL, LIST1(c), REF_OPER(continue_abnormally)));
7396 }
7397
7398 /*_     , guard-continuation */
7399 /* Each guard list is repeat (list continuation applicative) */
7400 /* We'd like to spec that applicative take 2 args, a continuation and
7401    a value, and be wrapped exactly once. */
7402 SIG_CHKARRAY(guard_continuation) =
7403 { K_ANY, REF_OPER(is_continuation), K_ANY, };
7404 DEF_SIMPLE_APPLICATIVE(ps0a3,guard_continuation,T_NO_K,ground, "guard-continuation")
7405 {
7406   WITH_3_ARGS(entry_guards, c, exit_guards);
7407   /* The spec wants an outer continuation to keeps sets of guards from
7408      being mixed together if there are two calls to guard_continuation
7409      with the same c.  But that happens naturally here, so it seems
7410      unneeded.  */
7411
7412   /* $$IMPROVE ME Copy the es of both lists of guards. */
7413   _kt_spagstack frame = cont_dump(c);
7414   if(entry_guards != K_NIL)
7415     {
7416       frame = klink_push_guards(frame, entry_guards, sc->envir, 0);
7417     }
7418   if(exit_guards != K_NIL)
7419     {
7420       frame = klink_push_guards(frame, exit_guards, sc->envir, 1);
7421     }
7422
7423   pko inner_cont = mk_continuation(frame);
7424   return inner_cont;
7425 }
7426
7427 /*_     , guard-dynamic-extent */
7428 SIG_CHKARRAY(guard_dynamic_extent) =
7429   {
7430     REF_OPER(is_finite_list),
7431     REF_OPER(is_applicative),
7432     REF_OPER(is_finite_list),
7433   };
7434   /* DOES NOT RETURN */
7435 DEF_SIMPLE_APPLICATIVE(ps0a3,guard_dynamic_extent,0,ground, "guard-dynamic-extent")
7436 {
7437   WITH_3_ARGS(entry,app,exit);
7438   pko cont = guard_continuation(sc,entry,current_continuation(sc),exit);
7439   pko cont2 = extend_continuation(sc,cont, app, sc->envir);
7440   /* Skip directly into the new continuation, don't invoke the
7441      guards */
7442   invoke_continuation(sc,cont2, K_NIL);
7443   /* NOTREACHED */
7444   return 0;
7445 }
7446
7447 /*_   , Keyed dynamic bindings */
7448 /*_    . klink_kdb_binder */
7449 SIG_CHKARRAY(klink_kdb_binder) =
7450 { REF_OPER(is_key), K_ANY, REF_OPER(is_combiner), };
7451 DEF_SIMPLE_CFUNC(ps0a3,klink_kdb_binder,T_NO_K)
7452 {
7453   WITH_3_ARGS(key, value, combiner);
7454   /* Check that combiner is in fact a combiner. */
7455   if(!is_combiner(combiner))
7456     {
7457       KERNEL_ERROR_1(sc,
7458                      "klink_kdb_binder: Arg 2 must be a combiner: ",
7459                      combiner);
7460     }
7461   /* Push the new binding. */
7462   klink_push_dyn_binding(sc, key, value);
7463   /* $$IMPROVE ME In general, should can control calling better than
7464      this.  Possibly do this thru invoke_continuation, except we're
7465      not arbitrarily changing continuations.  */
7466   /* $$IMPROVE ME Want a better way to control what environment to
7467      push in.  In fact, that's much like a dynamic variable. */
7468   /* $$IMPROVE ME Want a better and cheaper way to make empty
7469      environments. The vector thing should be controlled by a hint. */
7470   /* Make an empty static environment */
7471   new_frame_in_env(sc,K_NIL);
7472   /* Push combiner in that environment. */
7473   klink_push_cont(sc,combiner);
7474   /* And call it with no operands. */
7475   return K_NIL;
7476 }
7477 /* Combines with data to become "an applicative that takes two
7478   arguments, the second of which must be a oper. It calls its
7479   second argument with no operands (nil operand tree) in a fresh empty
7480   environment, and returns the result." */
7481 /*_    . klink_kdb_accessor */
7482 SIG_CHKARRAY(klink_kdb_accessor) =
7483 { REF_OPER(is_key), };
7484 DEF_SIMPLE_CFUNC(ps0a1,klink_kdb_accessor,T_NO_K)
7485 {
7486   WITH_1_ARGS(key);
7487   pko value = klink_find_dyn_binding(sc,key);
7488   if(!value)
7489     {
7490       KERNEL_ERROR_0(sc, "klink_kdb_accessor: No binding found");
7491     }
7492   return value;
7493 }
7494 /* Combines with data to become "an applicative that takes zero
7495   arguments. If the call to a occurs within the dynamic extent of a
7496   call to b, then a returns the value of the first argument passed to
7497   b in the smallest enclosing dynamic extent of a call to b. If the
7498   call to a is not within the dynamic extent of any call to b, an
7499   error is signaled."
7500  */
7501 /*_    . make_keyed_dynamic_variable */
7502 RGSTR(ground, "make-keyed-dynamic-variable", REF_OPER(make_keyed_dynamic_variable))
7503
7504 DEF_CFUNC(p00a0, make_keyed_dynamic_variable,K_NO_TYPE,T_NO_K)
7505 {
7506   return make_keyed_variable(
7507                              REF_OPER(klink_kdb_binder),
7508                              REF_OPER (klink_kdb_accessor));
7509 }
7510 /*_   , Profiling */
7511 #ifdef PROFILING
7512 /*_    . Structs */
7513 typedef struct profiling_data
7514 {
7515   int  num_calls;
7516   long num_evalloops;
7517 } profiling_data;
7518 typedef struct
7519 {
7520   pko     * objs;
7521   profiling_data * entries;
7522   int table_size;
7523   int alloced_size;
7524 } kt_profile_table;
7525 /*_    . Current data */
7526 /* This may be moved to per interpreter, or even more fine-grained. */
7527 /* This may not always be the way we get elapsed counts. */
7528 static long k_profiling_count = 0;
7529 static int k_profiling_p = 0;   /* Are we profiling now? */
7530 /* If we are profiling, init this if it's not initted */
7531 static kt_profile_table k_profiling_table = { 0 };
7532 /*_    . Dealing with table (All will be shared with other lookup tables) */
7533 /*_     , Init */
7534 void
7535 init_profile_table(kt_profile_table * p_table, int initial_size)
7536 {
7537   p_table->objs   = initial_size ?
7538     GC_MALLOC(sizeof(pko) * initial_size) : 0;
7539   p_table->entries = initial_size ?
7540     GC_MALLOC(sizeof(profiling_data) * initial_size)     : 0;
7541   p_table->alloced_size = initial_size;
7542   p_table->table_size = 0;
7543 }
7544 /*_     , Increase its size */
7545 void
7546 enlarge_profile_table(kt_profile_table * p_table)
7547 {
7548   if(p_table->table_size == p_table->alloced_size)
7549     {
7550       p_table->alloced_size *= 2;
7551       p_table->entries = GC_REALLOC(p_table->entries, sizeof(profiling_data) * p_table->alloced_size);
7552       p_table->objs = GC_REALLOC(p_table->objs, sizeof(pko) * p_table->alloced_size);
7553     }
7554
7555
7556 }
7557 /*_     , Searching in it */
7558 /* Use objtable_get_index */
7559 /*_    . On the stack */
7560 static struct stack_profiling *
7561 klink_find_profile_in_frame (_kt_spagstack frame, pko ff)
7562 {
7563   for( ;
7564       (frame != 0) && (frame->type != ksct_frame) ;
7565       frame = frame->next)
7566     {
7567       if(frame->type == ksct_profile)
7568         {
7569           struct stack_profiling *pdata = &frame->data.profiling;
7570           if(pdata->ff == ff) { return pdata; }
7571         }
7572     }
7573   return 0;
7574 }
7575 /*_    . Profile collection operations */
7576 /*_     , When eval loop steps */
7577 void
7578 k_profiling_step(void)
7579 { k_profiling_count++; }
7580 /*_     , When we begin executing a frame */
7581 /* Push a stack_profiling cell onto the frame.  */
7582
7583 void
7584 k_profiling_new_frame(klink * sc, pko ff)
7585 {
7586   if(!k_profiling_p) { return; }
7587   if(!is_operative(ff)) { return; }
7588   /* Do this only if ff is interesting (which for the moment means
7589      that it can be found in ground environment). */
7590   if(!reverse_binds_p(ff, ground_env)           &&
7591      !reverse_binds_p(ff, print_lookup_unwraps) &&
7592      !reverse_binds_p(ff, print_lookup_to_xary))
7593     { return; }
7594   struct stack_profiling * found_profile =
7595     klink_find_profile_in_frame (sc->dump, ff);
7596   /* If the same combiner is already being profiled in this frame,
7597      don't add another copy.  */
7598   if(found_profile)
7599     {
7600       /* $$IMPROVE ME Count tail calls */
7601     }
7602   else
7603     {
7604       /* Push a profiling frame */
7605       _kt_spagstack old_frame = sc->dump;
7606       _kt_spagstack frame =
7607         (_kt_spagstack)
7608         GC_MALLOC (sizeof (dump_stack_frame_cell));
7609       struct stack_profiling * pdata = &frame->data.profiling;
7610       pdata->ff            = ff;
7611       pdata->initial_count = k_profiling_count;
7612       pdata->returned_p    = 0;
7613       frame->type = ksct_profile;
7614       frame->next = old_frame;
7615       sc->dump = frame;
7616     }
7617 }
7618
7619 /*_     , When we pop a stack_profiling cell */
7620 void
7621 k_profiling_done_frame(klink * sc, struct stack_profiling * profile)
7622 {
7623   if(!k_profiling_p) { return; }
7624   profiling_data * pdata = 0;
7625   pko ff = profile->ff;
7626
7627   /* This stack_profiling cell is popped past but it might be used
7628      again if we re-enter, so mark it accordingly. */
7629   profile->returned_p = 1;
7630   if(k_profiling_table.alloced_size == 0)
7631     { init_profile_table(&k_profiling_table, 8); }
7632   else
7633     {
7634       int index = objtable_get_index(k_profiling_table.objs, k_profiling_table.table_size, ff);
7635       if(index >= 0)
7636         { pdata = &k_profiling_table.entries[index]; }
7637     }
7638
7639   /* Create it if needed */
7640   if(!pdata)
7641     {
7642       /* Increase size as needed */
7643       enlarge_profile_table(&k_profiling_table);
7644       /* Add entry */
7645       const int index = k_profiling_table.table_size;
7646       k_profiling_table.objs[index] = ff;
7647       k_profiling_table.table_size++;
7648       pdata = &k_profiling_table.entries[index];
7649       /* Initialize it here */
7650       pdata->num_calls     = 0;
7651       pdata->num_evalloops = 0;
7652     }
7653
7654   /* Add to its counts: Num calls.  Num eval-loops taken. */
7655   pdata->num_calls++;
7656   pdata->num_evalloops += k_profiling_count - profile->initial_count;
7657 }
7658 /*_    . Interface */
7659 /*_     , Turn profiling on */
7660 /* Maybe better as a command-line switch or binder. */
7661 SIG_CHKARRAY(profiling) = { REF_OPER(is_integer), };
7662 DEF_SIMPLE_APPLICATIVE (ps0a1, profiling,T_NO_K,ground, "profiling")
7663 {
7664   WITH_1_ARGS(profile_p);
7665   int pr = k_profiling_p;
7666   k_profiling_p = ivalue (profile_p);
7667   return mk_integer (pr);
7668 }
7669
7670 /*_     , Dumping profiling data */
7671 /* Return a list of the profiled combiners. */
7672 DEF_APPLICATIVE_W_DESTR(ps0a0,get_profiling_data,K_NO_TYPE,T_NO_K,ground,"get-profiling-data")
7673 {
7674   int index;
7675   pko result_list = K_NIL;
7676   for(index = 0; index < k_profiling_table.table_size; index++)
7677     {
7678       pko ff = k_profiling_table.objs[index];
7679       profiling_data * pdata = &k_profiling_table.entries[index];
7680
7681       /* Element format: (object num-calls num-evalloops) */
7682       result_list = cons(
7683                          LIST3(ff,
7684                                mk_integer(pdata->num_calls),
7685                                mk_integer(pdata->num_evalloops)),
7686                          result_list);
7687     }
7688   /* Don't care about order so no need to reverse the list. */
7689   return result_list;
7690 }
7691 /*_    . Reset profiling data */
7692 /*_   , Alternative definitions for no profiling */
7693 #else
7694 #define k_profiling_step()
7695 #define k_profiling_new_frame(DUMMY, DUMMY2)
7696 #endif
7697 /*_  . Error handling */
7698 /*_   , _klink_error_1 */
7699 static void
7700 _klink_error_1 (klink * sc, const char *s, pko a)
7701 {
7702 #if SHOW_ERROR_LINE
7703   const char *str = s;
7704   char sbuf[STRBUFFSIZE];
7705   pko the_inport = klink_find_dyn_binding(sc,K_INPORT);
7706   if (the_inport && (the_inport != K_NIL))
7707     {
7708       port * pt = portvalue(the_inport);
7709       /* Make sure error is not in REPL */
7710       if((pt->kind & port_file) && (pt->rep.stdio.file != stdin))
7711         {
7712           /* Count is 0-based but print it 1-based. */
7713           int ln = pt->rep.stdio.curr_line + 1;
7714           const char *fname = pt->rep.stdio.filename;
7715
7716           if (!fname)
7717             { fname = "<unknown>"; }
7718
7719           snprintf (sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
7720
7721           str = (const char *) sbuf;
7722         }
7723     }
7724 #else
7725   const char *str = s;
7726 #endif
7727   {
7728     pko err_arg;
7729     pko err_string = mk_string (str);
7730     if (a != 0)
7731       {
7732         err_arg = mcons (a, K_NIL);
7733       }
7734     else
7735       {
7736         err_arg = K_NIL;
7737       }
7738     err_arg = mcons (err_string, err_arg);
7739     invoke_continuation (sc, sc->error_continuation, err_arg);
7740   }
7741   /* NOTREACHED */
7742   return;
7743 }
7744
7745 /*_   , Default cheap error handlers */
7746 /*_    .  kernel_err */
7747 DEF_CFUNC (ps0a1, kernel_err, K_ANY,0)
7748 {
7749   WITH_REPORTER(0);
7750   if(arg1 == K_NIL)
7751     {
7752       putstr (sc, "Error with no arguments.  I know nut-ting!");
7753       return K_INERT;
7754     }
7755   if(!is_finite_list(arg1))
7756     {
7757       putstr (sc, "kernel_err: arg must be a finite list");
7758       return K_INERT;
7759     }
7760
7761   assert(is_pair(arg1));
7762   int got_string = is_string (car (arg1));
7763   pko args_x = got_string ? cdr (arg1) : arg1;
7764   const char *message = got_string ? string_value (car (arg1)) : " -- ";
7765
7766   putstr (sc, "Error: ");
7767   putstr (sc, message);
7768   return kernel_err_x (sc, args_x);
7769 }
7770
7771 /*_    . kernel_err_x */
7772 DEF_CFUNC (ps0a1, kernel_err_x, K_ANY_SINGLETON,0)
7773 {
7774   WITH_1_ARGS(args);
7775   WITH_REPORTER(0);
7776   putstr (sc, " ");
7777   if (args != K_NIL)
7778     {
7779       assert(is_pair(args));
7780       CONTIN_1 (dcrry_1dotALL, kernel_err_x, sc, cdr (args));
7781       klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
7782       CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, car (args));
7783       return K_INERT;
7784     }
7785   else
7786     {
7787       putstr (sc, "\n");
7788       return K_INERT;
7789     }
7790 }
7791 /*_    . kernel_err_return */
7792 DEF_CFUNC(ps0a1,kernel_err_return, K_ANY,0)
7793 {
7794   /* This should not set sc->done, because when it's called it still
7795      must print the error, which may require more eval loops.  */
7796   sc->retcode = 1;
7797   return kernel_err(sc, arg1);
7798 }
7799 /*_   , Interface */
7800 /*_    . error */
7801 DEF_APPLICATIVE_W_DESTR(ps0a1,error,K_ANY,0,ground,"error")
7802 {
7803   WITH_1_ARGS(err_arg);
7804   invoke_continuation (sc, sc->error_continuation, err_arg);
7805   return 0;                     /* NOTREACHED */
7806 }
7807 /*_    . error-descriptor? */
7808 /* $$WRITE ME TO replace the punted version */
7809
7810 /*_  . Support for calling C functions */
7811
7812 /*_   , klink_call_cfunc_aux */
7813 static pko
7814 klink_call_cfunc_aux (klink * sc, const kt_cfunc * p_cfunc, pko * arg_array)
7815 {
7816   switch (p_cfunc->type)
7817     {
7818       /* For these macros, the arglist is parenthesized so is
7819          usable. */
7820
7821       /* ***************************************** */
7822       /* For function types returning bool as int (bXXaX) */
7823 #define CASE_CFUNCTYPE_bX(SUFFIX,ARGLIST)                       \
7824       case klink_ftype_##SUFFIX:                                \
7825         return kernel_bool(p_cfunc->func.f_##SUFFIX ARGLIST)
7826
7827       CASE_CFUNCTYPE_bX (b00a1, (arg_array[0]));
7828       CASE_CFUNCTYPE_bX (b00a2, (arg_array[0], arg_array[1]));
7829       CASE_CFUNCTYPE_bX (bs0a2, (sc, arg_array[0], arg_array[1]));
7830
7831 #undef CASE_CFUNCTYPE_bX
7832
7833
7834       /* ***************************************** */
7835       /* For function types returning pko (pXXaX) */
7836 #define CASE_CFUNCTYPE_pX(SUFFIX,ARGLIST)       \
7837       case klink_ftype_##SUFFIX:                \
7838         return p_cfunc->func.f_##SUFFIX ARGLIST
7839
7840       CASE_CFUNCTYPE_pX (p00a0, ());
7841       CASE_CFUNCTYPE_pX (p00a1, (arg_array[0]));
7842       CASE_CFUNCTYPE_pX (p00a2, (arg_array[0], arg_array[1]));
7843       CASE_CFUNCTYPE_pX (p00a3, (arg_array[0], arg_array[1], arg_array[2]));
7844
7845       CASE_CFUNCTYPE_pX (ps0a0, (sc));
7846       CASE_CFUNCTYPE_pX (ps0a1, (sc, arg_array[0]));
7847       CASE_CFUNCTYPE_pX (ps0a2, (sc, arg_array[0], arg_array[1]));
7848       CASE_CFUNCTYPE_pX (ps0a3, (sc, arg_array[0], arg_array[1], arg_array[2]));
7849       CASE_CFUNCTYPE_pX (ps0a4, (sc, arg_array[0], arg_array[1],
7850                                  arg_array[2], arg_array[3]));
7851       CASE_CFUNCTYPE_pX (ps0a5, (sc, arg_array[0], arg_array[1], arg_array[2], arg_array[3], arg_array[4]));
7852
7853 #undef CASE_CFUNCTYPE_pX
7854
7855
7856       /* ***************************************** */
7857       /* For function types returning void (vXXaX) */
7858 #define CASE_CFUNCTYPE_vX(SUFFIX,ARGLIST)       \
7859       case klink_ftype_##SUFFIX:                \
7860         p_cfunc->func.f_##SUFFIX ARGLIST;       \
7861       return K_INERT
7862
7863       CASE_CFUNCTYPE_vX (vs0a2, (sc, arg_array[0], arg_array[1]));
7864       CASE_CFUNCTYPE_vX (vs0a3, (sc, arg_array[0], arg_array[1], arg_array[2]));
7865
7866 #undef CASE_CFUNCTYPE_vX
7867
7868     default:
7869       KERNEL_ERROR_0 (sc,
7870                       "kernel_call: About that function type, I know nut-ting!");
7871     }
7872 }
7873 /*_   , klink_call_cfunc */
7874 static pko
7875 klink_call_cfunc (klink * sc, pko functor, pko env, pko args)
7876 {
7877   const kt_cfunc * p_cfunc = get_cfunc_func (functor);
7878   assert(p_cfunc->argcheck);
7879   const int max_args = destructure_how_many (p_cfunc->argcheck);
7880   pko arg_array[max_args];
7881   destructure_to_array(sc,args,
7882                        p_cfunc->argcheck,
7883                        arg_array,
7884                        max_args,
7885                        REF_OPER (k_resume_to_cfunc),
7886                        functor,
7887                        functor);
7888   return klink_call_cfunc_aux (sc, p_cfunc, arg_array);
7889 }
7890 /*_   , k_resume_to_cfunc */
7891 SIG_CHKARRAY (k_resume_to_cfunc) =
7892 {
7893   REF_OPER (is_destr_result),
7894   REF_KEY (K_TYCH_DOT),
7895   REF_OPER (is_cfunc),
7896 };
7897 DEF_SIMPLE_CFUNC (ps0a2, k_resume_to_cfunc, 0)
7898 {
7899   WITH_2_ARGS (destr_result, functor);
7900   assert_type (0, functor, T_CFUNC);
7901   const int max_args = 5;
7902   pko arg_array[max_args];
7903   destr_result_fill_array (destr_result, max_args, arg_array);
7904   return klink_call_cfunc_aux (sc, get_cfunc_func (functor), arg_array);
7905 }
7906 /*_  . Some decurriers */
7907 static pko
7908 dcrry_2A01VLL (klink * sc, pko args, pko value)
7909 {
7910   WITH_REPORTER(sc);
7911   return LIST2(car (args), value);
7912 }
7913 static pko dcrry_3A01dotVLL (klink * sc, pko args, pko value)
7914 {
7915   WITH_REPORTER(sc);
7916   return cons (car (args), value);
7917 }
7918 static pko
7919 dcrry_2CA01VLLA02 (klink * sc, pko args, pko value)
7920 {
7921   WITH_REPORTER(sc);
7922   return LIST2( cons (car (args), value), cadr (args));
7923 }
7924 /* May not be needed */
7925 static pko
7926 dcrry_3A01A02VLL (klink * sc, pko args, pko value)
7927 {
7928   WITH_REPORTER(sc);
7929   return LIST3(car (args), cadr (args), value);
7930 }
7931 static pko
7932 dcrry_2ALLVLL (klink * sc, pko args, pko value)
7933 {
7934   return LIST2(args, value);
7935 }
7936 static pko dcrry_2ALLV01     (klink * sc, pko args, pko value)
7937 {
7938   WITH_REPORTER(sc);
7939   return LIST2(args, car (value));
7940 }
7941
7942 static pko
7943 dcrry_NCVLLA01dotAX1 (klink * sc, pko args, pko value)
7944 {
7945   WITH_REPORTER(sc);
7946   return cons(cons (value, car (args)), cdr (args));
7947 }
7948 static pko dcrry_NdotALL (klink * sc, pko args, pko value)
7949 { return args; }
7950
7951 static pko dcrry_1ALL (klink * sc, pko args, pko value)
7952 { return cons( args, K_NIL ); }
7953
7954 static pko dcrry_5ALLdotVLL (klink * sc, pko args, pko value)
7955 { return cons (args, value); }
7956
7957 static pko dcrry_NVLLdotALL (klink * sc, pko args, pko value)
7958 { return cons (value, args); }
7959
7960 static pko
7961 dcrry_1VLL (klink * sc, pko args, pko value)
7962 { return LIST1 (value); }
7963
7964 /*_  . Defining */
7965 /*_   , Internal functions */
7966 /*_    . kernel_define_tree_aux */
7967 kt_destr_outcome
7968 kernel_define_tree_aux
7969 (klink * sc, pko value, pko formal, pko env, pko * extra_result)
7970 {
7971   WITH_REPORTER(0);
7972   if (is_pair (formal))
7973     {
7974       if (is_pair (value))
7975         {
7976           kt_destr_outcome outcome =
7977             kernel_define_tree_aux (sc, car (value), car (formal), env,
7978                                     extra_result);
7979           switch (outcome)
7980             {
7981             case destr_success:
7982               /* $$IMPROVE ME On error, give a more accurate position. */
7983               return
7984                 kernel_define_tree_aux (sc, cdr (value), cdr (formal), env,
7985                                         extra_result);
7986             case destr_err:
7987               return destr_err;
7988             case destr_must_call_k:
7989               /* $$IMPROVE ME Also schedule to resume the cdr */
7990               /* Operations to run, in reverse order. */
7991               *extra_result =
7992                 LISTSTAR3(
7993                       /* ^V= #inert */
7994                       REF_OPER (kernel_define_tree),
7995                       /* V= (value formal env) */
7996                       mk_load (LIST3 (cdr (value),
7997                                       cdr (formal),
7998                                       env)),
7999                       *extra_result);
8000               return destr_must_call_k;
8001             default:
8002               errx (7, "Unrecognized enumeration");
8003             }
8004         }
8005       if (is_promise (value))
8006         {
8007           /* Operations to run, in reverse order. */
8008           *extra_result =
8009             LIST5(
8010                   /* ^V= #inert */
8011                   REF_OPER (kernel_define_tree),
8012                   /* V= (forced-value formal env) */
8013                   mk_load (LIST3 (mk_load_ix (0, 0),
8014                                   formal,
8015                                   env)),
8016                   mk_store (K_ANY, 1),
8017                   /* V= forced-argobject */
8018                   REF_OPER (force),
8019                   /* ^V= (value) */
8020                   mk_load (LIST1 (value)));
8021           return destr_must_call_k;
8022         }
8023       else
8024         {
8025           _klink_error_1 (sc,
8026                            "kernel_define_tree: value must be a pair: ", value);
8027           return destr_err;             /* NOTREACHED */
8028         }
8029     }
8030   /* We can encounter NIL at the end of a non-dotted list, so mustn't
8031      try to bind it, and value list must end here too. */
8032   else if (formal == K_NIL)
8033     {
8034       if(value != K_NIL)
8035         {
8036           _klink_error_1 (sc,
8037                            "kernel_define_tree: too many args: ", value);
8038           return destr_err;             /* NOTREACHED */
8039         }
8040       return destr_success;
8041     }
8042   /* If formal is #ignore, don't try to bind it, do nothing. */
8043   else if (formal == K_IGNORE)
8044     {
8045       return destr_success;
8046     }
8047   /* If it's a symbol, bind it.  Even a promise is bound thus. */
8048   else if (is_symbol (formal))
8049     {
8050       kernel_define (env, formal, value);
8051       return destr_success;
8052     }
8053   else
8054     {
8055       _klink_error_1 (sc,
8056                       "kernel_define_tree: can't bind to: ", formal);
8057       return destr_err;         /* NOTREACHED */
8058     }
8059 }
8060 /*_    . kernel_define_tree */
8061 /* This can no longer be assumed to be T_NO_K, in case promises must
8062    be forced. */
8063 SIG_CHKARRAY(kernel_define_tree) =
8064 { K_ANY,  K_ANY, REF_OPER(is_environment), };
8065 DEF_SIMPLE_CFUNC(vs0a3,kernel_define_tree,0)
8066 {
8067   WITH_3_ARGS(value, formal, env);
8068   pko extra_result;
8069   kt_destr_outcome outcome =
8070     kernel_define_tree_aux(sc, value, formal, env, &extra_result);
8071   switch (outcome)
8072     {
8073     case destr_success:
8074       break;
8075     case destr_err:
8076       /* Later this may raise the error */
8077       return;
8078     case destr_must_call_k:
8079       schedule_rv_list (sc, extra_result);
8080       return;
8081     default:
8082       errx (7, "Unrecognized enumeration");
8083     }
8084 }
8085 /*_    . kernel_define */
8086 SIG_CHKARRAY(kernel_define) =
8087 {
8088   REF_OPER(is_environment),
8089   REF_OPER(is_symbol),
8090   K_ANY,
8091 };
8092 DEF_SIMPLE_CFUNC(p00a3,kernel_define,T_NO_K)
8093 {
8094   WITH_3_ARGS(env, symbol, value);
8095   assert(is_symbol(symbol));
8096   pko x = find_slot_in_env (env, symbol, 0);
8097   if (x != 0)
8098     {
8099       set_slot_in_env (x, value);
8100     }
8101   else
8102     {
8103       new_slot_spec_in_env (env, symbol, value);
8104     }
8105   return K_INERT;
8106 }
8107 void klink_define (klink * sc, pko symbol, pko value)
8108 { kernel_define(sc->envir,symbol,value); }
8109
8110 /*_   , Supporting kernel registerables */
8111 /*_    . eval_define */
8112 RGSTR(ground, "$define!", REF_OPER(eval_define))
8113 SIG_CHKARRAY(eval_define) =
8114 { K_ANY, K_ANY, };
8115 DEF_SIMPLE_CFUNC(ps0a2,eval_define,0)
8116 {
8117   pko env = sc->envir;
8118   WITH_2_ARGS(formal, expr);
8119   CONTIN_2(dcrry_3VLLdotALL,kernel_define_tree,sc,formal,env);
8120   /* Using args functionality:
8121      BEFORE:
8122      make 2 new slots
8123      put formal in 2,
8124      put env in 3,
8125
8126      RUN, in reverse order
8127      kernel_define_tree (CONTIN_0)
8128      make arglist from 3 args ($$WRITE MY SUPPORT) - or from 2 args and value.
8129      (The 2 slots will go here)
8130      put return value in new slot ($$WRITE MY SUPPORT)
8131      kernel_eval
8132
8133
8134      Possibly "make arglist" will be an array of integers, -1 meaning
8135      the current value.  And on its own it could do decurrying.
8136    */
8137   return kernel_eval(sc,expr,env);
8138 }
8139 /*_    . set */
8140 RGSTR(ground, "$set!", REF_OPER(set))
8141 SIG_CHKARRAY(set) =
8142 { K_ANY, K_ANY, K_ANY, };
8143 DEF_SIMPLE_CFUNC(ps0a3,set,0)
8144 {
8145   pko env = sc->envir;
8146   WITH_3_ARGS(env_expr, formal, expr);
8147   /* Using args functionality:
8148
8149      RUN, in reverse order
8150      kernel_define_tree (CONTIN_0)
8151      make arglist from 3 args - or from 2 args and value.
8152      put return value in new slot
8153      kernel_eval
8154      make arglist from 1 arg
8155      env_expr in slot
8156      formal in slot
8157      put return value in new slot
8158      kernel_eval
8159      expr (Passed directly)
8160
8161    */
8162
8163   CONTIN_0(kernel_define_tree,sc);
8164   return
8165     kernel_mapeval(sc, K_NIL,
8166                    LIST3(expr,
8167                          LIST2(REF_OPER (arg1), formal),
8168                          env_expr),
8169                    env);
8170 }
8171
8172 /*_  . Misc Kernel functions */
8173 /*_   , tracing */
8174
8175 SIG_CHKARRAY(tracing) = { REF_OPER(is_integer), };
8176 DEF_SIMPLE_APPLICATIVE (ps0a1, tracing,T_NO_K,ground, "tracing")
8177 {
8178   WITH_1_ARGS(trace_p);
8179   int tr = sc->tracing;
8180   sc->tracing = ivalue (trace_p);
8181   return mk_integer (tr);
8182 }
8183
8184 /*_   , new_tracing */
8185
8186 SIG_CHKARRAY(new_tracing) = { REF_OPER(is_integer), };
8187 DEF_SIMPLE_APPLICATIVE (ps0a1, new_tracing,T_NO_K,ground, "new-tracing")
8188 {
8189   WITH_1_ARGS(trace_p);
8190   int tr = sc->new_tracing;
8191   sc->new_tracing = ivalue (trace_p);
8192   return mk_integer (tr);
8193 }
8194
8195
8196 /*_   , get-current-environment */
8197 DEF_APPLICATIVE_W_DESTR (ps0a0, get_current_environment, K_NO_TYPE,T_NO_K,ground, "get-current-environment")
8198 { return sc->envir; }
8199
8200 /*_   , arg1, $quote, list */
8201 DEF_APPLICATIVE_W_DESTR (ps0a1, arg1, K_ANY_SINGLETON,T_NO_K,ground, "identity")
8202 {
8203   WITH_1_ARGS(p);
8204   return p;
8205 }
8206 /* Same, unwrapped */
8207 RGSTR(ground, "$quote",   REF_OPER(arg1))
8208
8209 /*_   , val2val */
8210 RGSTR(ground, "list", REF_APPL(val2val))
8211 /* The underlying C function here is "arg1", but it's called with
8212    the whole argobject as arg1 */
8213 /* K_ANY instead of REF_OPER(is_finite_list) because we deliberately allow
8214    non-lists and improper lists. */
8215 DEF_CFUNC_RAW(OPER(val2val),ps0a1,arg1,K_ANY,T_NO_K);
8216 DEF_BOXED_APPLICATIVE(val2val, REF_OPER (val2val));
8217
8218 /*_   , k_quit */
8219 RGSTR(ground,"exit",REF_OPER(k_quit))
8220 DEF_CFUNC(ps0a0,k_quit,K_NO_TYPE,0)
8221 {
8222   if(!nest_depth_ok_p(sc))
8223     { sc->retcode = 1; }
8224
8225   sc->done = 1;
8226   return K_INERT;               /* Value is unused anyways */
8227 }
8228 /*_   , gc */
8229 RGSTR(ground,"gc",REF_OPER(k_gc))
8230 DEF_CFUNC(ps0a0,k_gc,K_NO_TYPE,0)
8231 {
8232   GC_gcollect();
8233   return K_INERT;
8234 }
8235
8236 /*_   , k_if */
8237
8238 RGSTR(ground, "$if", REF_OPER(k_if))
8239 FORWARD_DECL_CFUNC(static,ps0a3,k_if_literal);
8240 SIG_CHKARRAY(k_if) = { K_ANY, K_ANY, K_ANY, };
8241 DEF_SIMPLE_DESTR( k_if );
8242 SIG_CHAIN(k_if) =
8243   {
8244     /* Store (test consequent alternative) */
8245     ANON_STORE(REF_DESTR(k_if)),
8246
8247     ANON_LOAD(ANON_LIST1(ANON_LOAD_IX( 0, 0 ))),
8248     /* value = (test) */
8249
8250     REF_OPER(kernel_eval),
8251     /* test_result */
8252     /* Store (test_result) */
8253     ANON_STORE(K_ANY),
8254
8255     ANON_LOAD(ANON_LIST3(ANON_LOAD_IX( 0, 0 ),
8256                          ANON_LOAD_IX( 1, 1 ),
8257                          ANON_LOAD_IX( 1, 2 ))),
8258
8259     /* test_result, consequent, alternative */
8260     REF_OPER(k_if_literal),
8261   };
8262
8263 DEF_SIMPLE_CHAIN(k_if);
8264
8265 SIG_CHKARRAY(k_if_literal) = { REF_OPER(is_bool), K_ANY, K_ANY, };
8266 DEF_SIMPLE_CFUNC(ps0a3,k_if_literal,0)
8267 {
8268   WITH_3_ARGS(test, consequent, alternative);
8269   if(test == K_T) { return kernel_eval(sc, consequent, sc->envir); }
8270   if(test == K_F) { return kernel_eval(sc, alternative, sc->envir); }
8271   KERNEL_ERROR_1(sc,"Must be a boolean: ", test);
8272 }
8273
8274 /*_  . Routines for applicatives */
8275 BOX_OF_VOID (K_APPLICATIVE);
8276
8277 DEF_SIMPLE_PRED (is_applicative,T_NO_K,ground, "applicative?/o1")
8278 {
8279   WITH_1_ARGS(p);
8280   return is_encap (REF_KEY(K_APPLICATIVE), p);
8281 }
8282
8283 DEF_SIMPLE_PRED (is_combiner,T_NO_K,ground, "combiner?/o1")
8284 {
8285   WITH_1_ARGS(p);
8286   return is_applicative(p) || is_operative(p);
8287 }
8288
8289 SIG_CHKARRAY(wrap) = { REF_OPER(is_combiner) };
8290 DEF_SIMPLE_APPLICATIVE (p00a1, wrap,T_NO_K,ground, "wrap")
8291 {
8292   WITH_1_ARGS(p);
8293   return mk_encap (REF_KEY(K_APPLICATIVE), p);
8294 }
8295
8296 SIG_CHKARRAY(unwrap) = { REF_OPER(is_applicative) };
8297 DEF_SIMPLE_APPLICATIVE (ps0a1, unwrap,T_NO_K,ground, "unwrap")
8298 {
8299   WITH_1_ARGS(p);
8300   return unencap (sc, REF_KEY(K_APPLICATIVE), p);
8301 }
8302
8303 SIG_CHKARRAY(unwrap_all) = { REF_OPER(is_combiner) };
8304 DEF_SIMPLE_APPLICATIVE (p00a1, unwrap_all,T_NO_K,ground, "unwrap-all")
8305 {
8306   WITH_1_ARGS(p);
8307   /* Wrapping does not allowing circular wrapping, so this will
8308      terminate.  */
8309   while(is_encap (REF_KEY(K_APPLICATIVE), p))
8310     { p = unencap (0, REF_KEY(K_APPLICATIVE), p); }
8311   return p;
8312 }
8313
8314
8315 /*_  . Operatives */
8316 /*_   , is_operative */
8317 /* This can be hacked quicker by suppressing 1 more bit and testing
8318  * just once.  Requires keeping those T_ types co-ordinated, though. */
8319 DEF_SIMPLE_PRED (is_operative,T_NO_K,ground, "operative?/o1")
8320 {
8321   WITH_1_ARGS(p);
8322   return
8323        is_type (p, T_CFUNC)
8324     || is_type (p, T_CFUNC_RESUME)
8325     || is_type (p, T_CURRIED)
8326     || is_type (p, T_LISTLOOP)
8327     || is_type (p, T_CHAIN)
8328     || is_type (p, T_STORE)
8329     || is_type (p, T_LOAD)
8330     || is_type (p, T_TYPEP);
8331 }
8332
8333 /*_  . vau_1 */
8334 RGSTR(simple, "$vau/3", REF_OPER(vau_1))
8335
8336 /* This is a simple vau for bootstrap.  It handles just a single
8337    expression.  It's in ground for now, but will be only in
8338    low-for-optimization later */
8339
8340 /* $$IMPROVE ME Check that formals is a non-circular list with no
8341    duplicated symbols.  If this check is typical for
8342    kernel_define_tree (probably), pass that an initially blank
8343    environment and it can check for symbols and error if they are
8344    already defined.
8345
8346    eformal is almost REF_OPER(is_symbol) but must accept #ignore also.
8347 */
8348 SIG_CHKARRAY(vau_1) = { K_ANY, K_ANY, K_ANY };
8349 DEF_SIMPLE_CFUNC (ps0a3, vau_1,0)
8350 {
8351   pko env = sc->envir;
8352   WITH_3_ARGS(formals, eformal, expression);
8353   /* This defines a vau object.  Evaluating it is different.
8354      See 4.10.3 */
8355
8356   /* $$IMPROVE ME Could compile the expression now, but that's not so
8357      easy in Kernel. At least make a hook for that. */
8358
8359   /* Vau data is a list of the 4 things:
8360      The dynamic environment
8361      The eformal symbol
8362      An immutable copy of the formals es
8363      An immutable copy of the expression
8364
8365      $$IMPROVE ME Make not a list but a dedicated struct.
8366    */
8367   pko vau_data =
8368     LIST4(env,
8369           eformal,
8370           copy_es_immutable(sc, formals),
8371           copy_es_immutable (sc, expression));
8372   return
8373     mk_curried (dcrry_5VLLdotALL, vau_data, REF_OPER (eval_vau));
8374 }
8375
8376 /*_  . Evaluation, Kernel style */
8377 /*_   , Calling operatives */
8378 /*_    . eval_vau */
8379 /* Again, can't simply say REF_OPER(is_symbol) because it might be
8380    #ignore */
8381 SIG_CHKARRAY(eval_vau) =
8382 { K_ANY,
8383   REF_OPER(is_environment),
8384   K_ANY,
8385   K_ANY,
8386   K_ANY };
8387 DEF_SIMPLE_CFUNC (ps0a5, eval_vau,0)
8388 {
8389   pko env = sc->envir;
8390   WITH_5_ARGS(args, old_env, eformal, formals, expression);
8391
8392   /* Make a new environment, child of the static environment (which
8393      we get now while making the vau) and put it into the envir
8394      register. */
8395   new_frame_in_env (sc, old_env);
8396
8397   /* This will change in kernel_define, not here. */
8398   /* Bind the dynamic environment to the eformal symbol. */
8399   kernel_define_tree (sc, env, eformal, sc->envir);
8400
8401   /* Bind the formals (symbols) to the operands (values) treewise.  */
8402   pko extra_result;
8403   kt_destr_outcome outcome =
8404     kernel_define_tree_aux(sc, args, formals, sc->envir, &extra_result);
8405   switch (outcome)
8406     {
8407     case destr_success:
8408       break;
8409     case destr_err:
8410       /* Later this may raise the error */
8411       return K_INERT;
8412     case destr_must_call_k:
8413       CONTIN_2 (dcrry_2dotALL, kernel_eval, sc, expression, sc->envir);
8414       schedule_rv_list (sc, extra_result);
8415       return K_INERT;
8416     default:
8417       errx (7, "Unrecognized enumeration");
8418     }
8419
8420   /* Evaluate the expression. */
8421   return kernel_eval (sc, expression, sc->envir);
8422 }
8423
8424 /*_   , Kernel eval mutual callers */
8425 /*_    . kernel_eval */
8426
8427 /* Optionally define a tracing kernel_eval  */
8428 SIG_CHKARRAY(kernel_eval) = { K_ANY, REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
8429 DEF_SIMPLE_DESTR(kernel_eval);
8430 #if USE_TRACING
8431 FORWARD_DECL_CFUNC(static,ps0a2,kernel_real_eval);
8432 DEF_APPLICATIVE_W_DESTR (ps0a2, kernel_eval, REF_DESTR(kernel_eval),0,ground, "eval")
8433 {
8434   WITH_2_ARGS(form, env);
8435   /* $$RETHINK ME  Set sc->envir here, remove arg from
8436      kernel_real_eval, and the tracing call will know its own env,
8437      it may just be a closure with form as value. */
8438   if(env == K_INERT)
8439     {
8440       env = sc->envir;
8441     }
8442   if (sc->tracing)
8443     {
8444       CONTIN_2 (dcrry_2dotALL, kernel_real_eval, sc, form, env);
8445       putstr (sc, "\nEval: ");
8446       CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, form);
8447       return K_INERT;
8448     }
8449   else
8450     {
8451       return kernel_real_eval (sc, form, env);
8452     }
8453 }
8454 #endif
8455
8456 /* Define either kernel_eval (if not defined above) or kernel_real_eval  */
8457 #if USE_TRACING
8458 /* $$IMPROVE MY DESIGN  Don't like the pointers being different
8459    levels of pointingness.  In fact, we always potentially have
8460    tracing (or w/e) so let's lose the preprocessor condition. */
8461
8462 DEF_CFUNC (ps0a2, kernel_real_eval, REF_DESTR(kernel_eval),0)
8463 #else
8464 DEF_APPLICATIVE_W_DESTR (ps0a2, kernel_eval, REF_DESTR(kernel_eval),0,ground, "eval")
8465 #endif
8466 {
8467   WITH_REPORTER(0);
8468   WITH_2_ARGS(form, env);
8469
8470   /* Evaluate form in env */
8471   /* Arguments:
8472      form: form to be evaluated
8473      env: environment to evaluate it in.
8474    */
8475   assert (form);
8476   assert (env);
8477   /* $$IMPROVE ME Let this be done in kernel_eval and lose the env
8478      argument, here just assert that we have an environment. */
8479   if(env != K_INERT)
8480     {
8481       if (is_environment (env))
8482         { sc->envir = env; }
8483       else
8484         {
8485           KERNEL_ERROR_0 (sc, "eval: Arg 2 must be an environment:");
8486         }
8487     }
8488   /* symbol */
8489   if (is_symbol (form))
8490     {
8491       pko x = find_slot_in_env (env, form, 1);
8492       if (x != 0)
8493         {
8494           return slot_value_in_env (x);
8495         }
8496       else
8497         {
8498           KERNEL_ERROR_1 (sc, "eval: unbound variable:", form);
8499         }
8500     }
8501   /* pair */
8502   else if (is_pair (form))
8503     {
8504       CONTIN_2 (dcrry_3VLLdotALL, kernel_eval_aux, sc, cdr (form), env);
8505       return kernel_eval (sc, car (form), env);
8506     }
8507   /* Otherwise return the object literally. */
8508   else
8509     {
8510       return form;
8511     }
8512 }
8513 /*_    . kernel_eval_aux */
8514 /* The stage of `eval' when we've already decided that we're to use a
8515    combiner and what that combiner is. */
8516 /* $$IMPROVE ME  Lose the env argument, it's always sc->envir */
8517 SIG_CHKARRAY(kernel_eval_aux) =
8518 { REF_OPER(is_combiner), K_ANY, REF_OPER(is_environment), };
8519 DEF_SIMPLE_DESTR(kernel_eval_aux);
8520 DEF_CFUNC (ps0a3, kernel_eval_aux, REF_DESTR(kernel_eval_aux),0)
8521 {
8522   WITH_3_ARGS(functor, args, env);
8523   assert (is_environment (env));
8524   /* Args:
8525      functor: what the car of the form has evaluated to.
8526      args: cdr of form, as yet unevaluated.
8527      env: environment to evaluate in.
8528    */
8529   k_profiling_new_frame(sc, functor);
8530   if(is_type(functor, T_CFUNC))
8531     {
8532       return klink_call_cfunc(sc, functor, env, args);
8533     }
8534   else if(is_type(functor, T_CURRIED))
8535     {
8536       return call_curried(sc, functor, args);
8537     }
8538   else if(is_type(functor, T_TYPEP))
8539     {
8540       /* $$MOVE ME Into something paralleling the other operative calls */
8541       /* $$IMPROVE ME  Check arg number */
8542       WITH_REPORTER(0);
8543       if(!is_pair(args))
8544         { KERNEL_ERROR_1 (sc, "Takes one arg: ", functor); }
8545       return kernel_bool(call_T_typecheck(functor,car(args)));
8546     }
8547   else if(is_type(functor, T_LISTLOOP))
8548     {
8549       return eval_listloop(sc, functor,args);
8550     }
8551   else if(is_type(functor, T_CHAIN))
8552     {
8553       return eval_chain( sc, functor, args );
8554     }
8555   else if ( is_type( functor, T_STORE ))
8556     {
8557       return k_do_store( sc, functor, args );
8558     }
8559   else if ( is_type( functor, T_LOAD ))
8560     {
8561       return k_do_load( sc, functor, args );
8562     }
8563   else if (is_applicative (functor))
8564     {
8565       /* Operation:
8566          Get the underlying operative.
8567          Evaluate arguments (may make frames)
8568          Use the oper on the arguments
8569        */
8570       pko oper = unwrap (sc, functor);
8571       assert (oper);
8572       int4 metrics;
8573       get_list_metrics_aux(args, metrics);
8574       if(metrics[lm_cyc_len] != 0)
8575         {
8576           KERNEL_ERROR_1 (sc, "kernel_eval_aux: Arguments must be a list", args);
8577         }
8578       sc->envir = env;          /* $$IMPROVE ME  Treat this cache better */
8579       CONTIN_2 (dcrry_2CA01VLLA02, kernel_eval, sc, oper, env);
8580 #if USE_TRACING
8581       if (sc->tracing)
8582         {
8583           CONTIN_3 (dcrry_4dotALL, kernel_mapeval, sc, K_NIL, args, env);
8584           CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, args);
8585           putstr (sc, "\nApply to: ");
8586           return K_T;
8587         }
8588       else
8589 #endif
8590         { return kernel_mapeval (sc, K_NIL, args, env); }
8591     }
8592   else
8593     {
8594       KERNEL_ERROR_1 (sc, "eval: can't apply:", functor);
8595     }
8596 }
8597 /*_   , Eval mappers */
8598 /*_    . kernel_mapeval */
8599 /* Evaluate each datum in list arg2, Kernel-returning a list of the results. */
8600 SIG_CHKARRAY(kernel_mapeval) =
8601 { REF_OPER(is_finite_list), REF_OPER(is_finite_list), REF_OPER(is_environment), };
8602 DEF_SIMPLE_DESTR(kernel_mapeval);
8603 DEF_CFUNC (ps0a3, kernel_mapeval, REF_DESTR(kernel_mapeval),0)
8604 {
8605   WITH_REPORTER(0);
8606   WITH_3_ARGS(accum, args, env);
8607   assert (is_environment (env));
8608   /* Arguments:
8609      accum:
8610      * The list of evaluated arguments, in reverse order.
8611      * Purpose: Used as an accumulator.
8612
8613      args: list of forms to be evaluated.
8614      * Precondition: Must be a proper list (is_list must give true)
8615      * When called by itself: The forms that remain yet to be evaluated
8616
8617      env: The environment to evaluate in.
8618   */
8619
8620   /* If there are remaining arguments, arrange to evaluate one,
8621      add the result to accumulator, and return control here. */
8622   if (is_pair (args))
8623     {
8624       /* This can't be converted to a loop because we don't know
8625          whether kernel_eval_aux will create more frames. */
8626       CONTIN_3 (dcrry_3CVLLA01dotAX1,
8627                 kernel_mapeval, sc, accum, cdr (args), env);
8628       return kernel_eval (sc, car (args), env);
8629     }
8630   /* If there are no remaining arguments, reverse the accumulator
8631      and return it.  Can't reverse in place because other
8632      continuations might re-use the same accumulator state.  */
8633   else if (args == K_NIL)
8634     { return reverse (sc, accum); }
8635   else
8636     {
8637       /* This shouldn't be reachable because we check for it being
8638          a list beforehand in kernel_eval_aux. */
8639       errx (4, "mapeval: arguments must be a list:");
8640     }
8641 }
8642
8643 RGSTR(ground,"$bad-sequence",REF_OPER(kernel_sequence))
8644 SIG_CHKARRAY(kernel_sequence) =
8645 { REF_KEY(K_TYCH_DOT), REF_OPER(is_countable_list), };
8646 DEF_SIMPLE_CFUNC(ps0a1,kernel_sequence,0)
8647 {
8648   WITH_1_ARGS(forms);
8649   /* Ultimately return #inert */
8650   /* $$IMPROVE ME This shouldn't accumulate args only to discard
8651      them. */
8652   CONTIN_0_RAW(mk_curried(dcrry_NdotALL, K_INERT, 0), sc);
8653   return kernel_mapeval(sc,K_NIL,forms,sc->envir);
8654 }
8655
8656 /*_    . kernel_mapand_aux */
8657 /* Call proc on each datum in args, Kernel-returning true if all
8658    succeed, otherwise false. */
8659 SIG_CHKARRAY(kernel_mapand_aux) =
8660 { REF_OPER(is_bool),
8661   REF_OPER(is_combiner),
8662   REF_OPER(is_finite_list),
8663 };
8664 DEF_SIMPLE_CFUNC (ps0a3, kernel_mapand_aux,0)
8665 {
8666   WITH_REPORTER(0);
8667   WITH_3_ARGS(ok, proc, args);
8668   /* Arguments:
8669      * succeeded:
8670        * Whether the last invocation of this succeeded.  Initialize with
8671          K_T.
8672
8673      * proc: A boolean combiner (predicate) to apply to these objects
8674
8675      * args: list of objects to apply proc to
8676        * Precondition: Must be a proper list
8677   */
8678   if(ok == K_F)
8679     { return K_F; }
8680   if(ok != K_T)
8681     { KERNEL_ERROR_1(sc, "kernel_mapand_aux: Must be boolean: ", ok); }
8682   /* If there are remaining arguments, arrange to evaluate one and
8683      return control here. */
8684   if (is_pair (args))
8685     {
8686       /* This can't be converted to a loop because we don't know
8687          whether kernel_eval_aux will create more frames. */
8688       CONTIN_2 (dcrry_3VLLdotALL,
8689                 kernel_mapand_aux, sc, proc, cdr (args));
8690       return kernel_eval_aux (sc, proc, car (args), sc->envir);
8691     }
8692   /* If there are no remaining arguments, return true.  */
8693   else if (args == K_NIL)
8694     { return K_T; }
8695   else
8696     {
8697       /* This shouldn't be reachable because we check for it being a
8698          list beforehand. */
8699       errx (4, "mapbool: arguments must be a list:");
8700     }
8701 }
8702
8703 /*_    . kernel_mapand */
8704 SIG_CHKARRAY(kernel_mapand) =
8705 { REF_OPER(is_combiner),
8706   REF_OPER(is_finite_list),
8707 };
8708 DEF_SIMPLE_APPLICATIVE (ps0a2, kernel_mapand,0,simple, "every?/2-xary")
8709 {
8710   WITH_2_ARGS(proc, args);
8711   /* $$IMPROVE ME  Get list metrics here and if we get a circular
8712      list, treat it correctly (How is TBD). */
8713   return kernel_mapand_aux(sc,REF_KEY(K_T), proc, args);
8714 }
8715 /*_    . kernel_mapor_aux */
8716 /* Call proc on each datum in args, Kernel-returning true if all
8717    succeed, otherwise false. */
8718 SIG_CHKARRAY(kernel_mapor_aux) =
8719 { REF_OPER(is_bool),
8720   REF_OPER(is_combiner),
8721   REF_OPER(is_finite_list),
8722 };
8723 DEF_SIMPLE_CFUNC (ps0a3, kernel_mapor_aux,0)
8724 {
8725   WITH_REPORTER(0);
8726   WITH_3_ARGS(ok, proc, args);
8727   /* Arguments:
8728      * succeeded:
8729        * Whether the last invocation of this succeeded.  Initialize with
8730          K_T.
8731
8732      * proc: A boolean combiner (predicate) to apply to these objects
8733
8734      * args: list of objects to apply proc to
8735        * Precondition: Must be a proper list
8736   */
8737   if(ok == K_T)
8738     { return K_T; }
8739   if(ok != K_F)
8740     { KERNEL_ERROR_1(sc, "kernel_mapor_aux: Must be boolean: ", ok); }
8741   /* If there are remaining arguments, arrange to evaluate one and
8742      return control here. */
8743   if (is_pair (args))
8744     {
8745       /* This can't be converted to a loop because we don't know
8746          whether kernel_eval_aux will create more frames. */
8747       CONTIN_2 (dcrry_3VLLdotALL,
8748                 kernel_mapor_aux, sc, proc, cdr (args));
8749       return kernel_eval_aux (sc, proc, car (args), sc->envir);
8750     }
8751   /* If there are no remaining arguments, return false.  */
8752   else if (args == K_NIL)
8753     { return K_F; }
8754   else
8755     {
8756       /* This shouldn't be reachable because we check for it being a
8757          list beforehand. */
8758       errx (4, "mapbool: arguments must be a list:");
8759     }
8760 }
8761 /*_    . kernel_mapor */
8762 SIG_CHKARRAY(kernel_mapor) =
8763 { REF_OPER(is_combiner),
8764   REF_OPER(is_finite_list),
8765 };
8766 DEF_SIMPLE_APPLICATIVE (ps0a2, kernel_mapor,0,simple, "some?/2-xary")
8767 {
8768   WITH_2_ARGS(proc, args);
8769   /* $$IMPROVE ME  Get list metrics here and if we get a circular
8770      list, treat it correctly (How is TBD). */
8771   return kernel_mapor_aux(sc,REF_KEY(K_F), proc, args);
8772 }
8773
8774 /*_   , Kernel combiners */
8775 /*_    . $and? */
8776 /* $$IMPROVE ME  Make referring to curried operatives neater. */
8777 RGSTR(ground, "$and?", REF_OBJ(k_oper_andp))
8778 DEF_BOXED_CURRIED(k_oper_andp,
8779                   dcrry_2ALLVLL,
8780                   REF_OPER(kernel_internal_eval),
8781                   REF_OPER(kernel_mapand));
8782
8783 /*_    . $or? */
8784 RGSTR(ground, "$or?", REF_OBJ(k_oper_orp))
8785 DEF_BOXED_CURRIED(k_oper_orp,
8786                   dcrry_2ALLVLL,
8787                   REF_OPER(kernel_internal_eval),
8788                   REF_OPER(kernel_mapor));
8789
8790 /*_   , map */
8791 /*_    . k_counted_map_aux */
8792 /* $$USE ME MORE Export both to simple: "counted-map1-car"
8793    "counted-map1-cdr" */
8794 pko
8795 k_counted_map_car(klink * sc, int count, pko list, _kt_tag t_enum)
8796 {
8797   int i;
8798   pko rv_result = K_NIL;
8799   for(i = 0; i < count; ++i, list = pair_cdr(0, list))
8800     {
8801       assert(is_pair(list));
8802       pko obj = pair_car(0, list);
8803       rv_result = v2cons (t_enum, pair_car(sc, obj), rv_result);
8804     }
8805
8806   /* Reverse the list in place. */
8807   return unsafe_v2reverse_in_place(K_NIL, rv_result);
8808 }
8809
8810 pko
8811 k_counted_map_cdr(klink * sc, int count, pko list, _kt_tag t_enum)
8812 {
8813   int i;
8814   pko rv_result = K_NIL;
8815   for(i = 0; i < count; ++i, list = pair_cdr(0, list))
8816     {
8817       assert(is_pair(list));
8818       pko obj = pair_car(0, list);
8819       rv_result = v2cons (t_enum, pair_cdr(sc, obj), rv_result);
8820     }
8821
8822   /* Reverse the list in place. */
8823   return unsafe_v2reverse_in_place(K_NIL, rv_result);
8824 }
8825
8826 /* Evaluate COUNT datums in list ARGS, Kernel-returning a list of the
8827    results. */
8828 SIG_CHKARRAY(k_counted_map_aux) =
8829 { REF_OPER(is_finite_list),
8830   REF_OPER(is_integer),
8831   REF_OPER(is_integer),
8832   REF_OPER(is_operative),
8833   REF_OPER(is_finite_list),
8834 };
8835 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_map_aux, 0,simple, "counted-map/5")
8836 {
8837   WITH_5_ARGS(accum, count, len, oper, args);
8838   assert (is_integer (count));
8839   /* $$IMPROVE ME  Check the other args too */
8840
8841   /* Arguments:
8842      accum:
8843      * The list of evaluated arguments, in reverse order.
8844      * Purpose: Used as an accumulator.
8845
8846      count:
8847      * The number of arguments remaining
8848
8849      len:
8850      * The effective length of args.
8851
8852      oper
8853      * An xary operative
8854
8855      args: list of lists of arguments to this.
8856
8857      * Precondition: Must be a proper list (is_finite_list must give
8858        true).  args will not be cyclic, we'll check for and handle
8859        encycling outside of here.
8860   */
8861
8862   /* If there are remaining arguments, arrange to operate on one, cons
8863      the result to accumulator, and return control here. */
8864   if (ivalue (count) > 0)
8865     {
8866       assert(is_pair(args));
8867       int len_v = ivalue(len);
8868       /* This can't be converted to a loop because we don't know
8869          whether kernel_eval_aux will create more frames.
8870
8871          $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8872       */
8873       CONTIN_5 (dcrry_5CVLLA01dotAX1,
8874                 k_counted_map_aux, sc, accum,
8875                 mk_integer(ivalue(count) - 1),
8876                 len,
8877                 oper,
8878                 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8879
8880       return kernel_eval_aux (sc,
8881                               oper,
8882                               k_counted_map_car(sc, len_v, args, T_PAIR),
8883                               sc->envir);
8884     }
8885   /* If there are no remaining arguments, reverse the accumulator
8886      and return it.  Can't reverse in place because other
8887      continuations might re-use the same accumulator state.  */
8888   else
8889     { return reverse (sc, accum); }
8890 }
8891
8892 /*_   , every? */
8893 /*_    . counted-every?/5 */
8894 SIG_CHKARRAY(k_counted_every) =
8895 { REF_OPER(is_bool),
8896   REF_OPER(is_integer),
8897   REF_OPER(is_integer),
8898   REF_OPER(is_operative),
8899   REF_OPER(is_finite_list),
8900 };
8901 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_every,0,simple,"counted-every?/5")
8902 {
8903   WITH_5_ARGS(ok, count, len, oper, args);
8904   assert (is_bool (ok));
8905   assert (is_integer (count));
8906   assert (is_integer (len));
8907
8908   /* Arguments:
8909      * succeeded:
8910        * Whether the last invocation of this succeeded.  Initialize with
8911          K_T.
8912
8913      count:
8914      * The number of arguments remaining
8915
8916      len:
8917      * The effective length of args.
8918
8919      oper
8920      * An xary operative
8921
8922      args: list of lists of arguments to this.
8923
8924      * Precondition: Must be a proper list (is_finite_list must give
8925        true).  args will not be cyclic, we'll check for and handle
8926        encycling outside of here.
8927   */
8928
8929   if(ok == K_F)
8930     { return K_F; }
8931   if(ok != K_T)
8932     { KERNEL_ERROR_1(sc, "k_counted_every: Must be boolean: ", ok); }
8933
8934   /* If there are remaining arguments, arrange to evaluate one and
8935      return control here. */
8936   if (ivalue (count) > 0)
8937     {
8938       assert(is_pair(args));
8939       int len_v = ivalue(len);
8940       /* This can't be converted to a loop because we don't know
8941          whether kernel_eval_aux will create more frames.
8942
8943          $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8944       */
8945       CONTIN_4 (dcrry_4VLLdotALL,
8946                 k_counted_every, sc,
8947                 mk_integer(ivalue(count) - 1),
8948                 len,
8949                 oper,
8950                 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8951
8952       return kernel_eval_aux (sc,
8953                               oper,
8954                               k_counted_map_car(sc, len_v, args, T_PAIR),
8955                               sc->envir);
8956     }
8957   /* If there are no remaining arguments, return true.  */
8958   else
8959     { return K_T; }
8960 }
8961
8962 /*_   , some? */
8963 /*_    . counted-some?/5 */
8964 SIG_CHKARRAY(k_counted_some) =
8965 { REF_OPER(is_bool),
8966   REF_OPER(is_integer),
8967   REF_OPER(is_integer),
8968   REF_OPER(is_operative),
8969   REF_OPER(is_finite_list),
8970 };
8971 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_some,0,simple,"counted-some?/5")
8972 {
8973   WITH_5_ARGS(ok, count, len, oper, args);
8974   assert (is_bool (ok));
8975   assert (is_integer (count));
8976   assert (is_integer (len));
8977
8978   if(ok == K_T)
8979     { return K_T; }
8980   if(ok != K_F)
8981     { KERNEL_ERROR_1(sc, "k_counted_some: Must be boolean: ", ok); }
8982
8983   /* If there are remaining arguments, arrange to evaluate one and
8984      return control here. */
8985   if (ivalue (count) > 0)
8986     {
8987       assert(is_pair(args));
8988       int len_v = ivalue(len);
8989       /* This can't be converted to a loop because we don't know
8990          whether kernel_eval_aux will create more frames.
8991
8992          $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8993       */
8994       CONTIN_4 (dcrry_4VLLdotALL,
8995                 k_counted_some, sc,
8996                 mk_integer(ivalue(count) - 1),
8997                 len,
8998                 oper,
8999                 k_counted_map_cdr(sc, len_v, args, T_PAIR));
9000
9001       return kernel_eval_aux (sc,
9002                               oper,
9003                               k_counted_map_car(sc, len_v, args, T_PAIR),
9004                               sc->envir);
9005     }
9006   /* If there are no remaining arguments, return false.  */
9007   else
9008     { return K_F; }
9009 }
9010
9011
9012 /*_  . Klink top level */
9013 /*_   , kernel_repl */
9014 DEF_CFUNC(ps0a0, kernel_repl, K_NO_TYPE,0)
9015 {
9016   /* If we reached the end of file, this loop is done. */
9017   port *pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
9018
9019   if (pt->kind & port_saw_EOF)
9020     { return K_INERT; }
9021
9022   putstr (sc, "\n");
9023   putstr (sc, prompt);
9024
9025   assert (is_environment (sc->envir));
9026
9027   /* Arrange another iteration */
9028   CONTIN_0 (kernel_repl, sc);
9029   klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
9030   klink_push_cont(sc, REF_OBJ(print_value));
9031 #if USE_TRACING
9032   CONTIN_1 (dcrry_2A01VLL, tracing_say, sc, mk_string("\nGives: "));
9033 #endif
9034   CONTIN_0 (kernel_internal_eval, sc);
9035   CONTIN_0 (kernel_read_internal, sc);
9036   return K_INERT;
9037 }
9038
9039 /*_   , kernel_rel */
9040 static const kt_vector rel_chain =
9041   {
9042     3,
9043     ((pko[])
9044     {
9045       REF_OPER(kernel_read_internal),
9046         REF_OPER(kernel_internal_eval),
9047         REF_OPER(kernel_rel),
9048         }),
9049   };
9050
9051 DEF_CFUNC(ps0a0, kernel_rel, K_NO_TYPE,0)
9052 {
9053   /* If we reached the end of file, this loop is done. */
9054   port *pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
9055
9056   if (pt->kind & port_saw_EOF)
9057     { return K_INERT; }
9058
9059   assert (is_environment (sc->envir));
9060
9061 #if 1
9062   schedule_chain( sc, &rel_chain);
9063 #else
9064   /* Arrange another iteration */
9065   CONTIN_0 (kernel_rel, sc);
9066   CONTIN_0 (kernel_internal_eval, sc);
9067   CONTIN_0 (kernel_read_internal, sc);
9068 #endif
9069   return K_INERT;
9070 }
9071
9072 /*_   , kernel_internal_eval */
9073 /* Convert the aftermath of kernel_read_internal to something kernel_eval
9074    can accept.  */
9075 /* $$IMPROVE ME realize this as a currier.  But it's not a curried
9076    object as such because it carries no internal data.  */
9077 DEF_CFUNC (ps0a1, kernel_internal_eval, K_ANY,0)
9078 {
9079   pko value = arg1;
9080   if( sc->new_tracing )
9081     { klink_push_dyn_binding( sc, K_TRACING, K_T ); }
9082   return kernel_eval (sc, value, sc->envir);
9083 }
9084
9085 /*_  . Constructing environments */
9086 /*_   , Declarations for built-in environments */
9087 /* These are initialized before they are registered. */
9088 static pko print_lookup_env = 0;
9089 static pko all_builtins_env = 0;
9090 static pko ground_env       = 0;
9091 #define unsafe_env ground_env
9092 #define simple_env ground_env
9093 static pko typecheck_env_syms = 0;
9094
9095 /*_   , What to include */
9096 #ifndef COLLECT_RGSTRS          /* If we're collecting, these files may not
9097                                    have been generated yet */
9098 const kernel_registerable preregister[] =
9099   {
9100     /* $$MOVE ME These others will move into dedicated arrays, and be
9101        combined so that they can all be seen in init.krn but not in
9102        ground env. */
9103 #include "registerables/ground.inc"
9104 #include "registerables/unsafe.inc"
9105 #include "registerables/simple.inc"
9106     /* $$TRANSITIONAL */
9107     { "type?",                       REF_APPL(typecheck),                },
9108     { "do-destructure",              REF_APPL(do_destructure),           },
9109   };
9110
9111 const kernel_registerable all_builtins[] =
9112   {
9113 #include "registerables/all-builtins.inc"
9114   };
9115
9116 const kernel_registerable print_lookup_rgsts[] =
9117 {
9118   { "#f",      REF_KEY(K_F),       },
9119   { "#t",      REF_KEY(K_T),       },
9120   { "#inert",  REF_KEY(K_INERT),   },
9121   { "#ignore", REF_KEY(K_IGNORE),  },
9122
9123   { "$quote",  REF_OPER(arg1),     },
9124
9125   /* $$IMPROVE ME  Add the other quote-like symbols here. */
9126   /* quasiquote, unquote, unquote-splicing */
9127
9128 };
9129
9130 const kernel_registerable typecheck_syms_rgsts[] =
9131   {
9132 #include "registerables/type-keys.inc"
9133   };
9134 #endif
9135
9136
9137 /*_   , How to add */
9138
9139 /* Bind each of an array of kernel_registerables into env. */
9140 void
9141 k_register_list (const kernel_registerable * list, int count, pko env)
9142 {
9143   int i;
9144   assert(list);
9145   assert (is_environment (env));
9146   for (i = 0; i < count; i++)
9147     {
9148       kernel_define (env, mk_symbol (list[i].name), list[i].data);
9149     }
9150 }
9151
9152 /*_   , k_regstrs_to_env */
9153 pko
9154 k_regstrs_to_env(const kernel_registerable * list, int count)
9155 {
9156   pko env = make_new_frame(K_NIL);
9157   k_register_list (list, count, env);
9158   return env;
9159 }
9160
9161 #define K_REGSTRS_TO_ENV(RGSTRS)\
9162   k_regstrs_to_env(RGSTRS, sizeof (RGSTRS) / sizeof (RGSTRS[0]))
9163 /*_   , setup_print_secondary_lookup */
9164 static pko print_lookup_unwraps = 0;
9165 static pko print_lookup_to_xary = 0;
9166 void
9167 setup_print_secondary_lookup(void)
9168 {
9169   /* Quick and dirty: Set up tables corresponding to the ground env
9170      and put the registering stuff in them. */
9171   /* What this really accomplishes is to make prepared lookup tables
9172      available for particular print operations.  Later we'll use a
9173      more general approach and this will become just a cache. */
9174   print_lookup_unwraps = make_new_frame(K_NIL);
9175   print_lookup_to_xary = make_new_frame(K_NIL);
9176   int i;
9177   const kernel_registerable * list = preregister;
9178   int count = sizeof (preregister) / sizeof (preregister[0]);
9179   for (i = 0; i < count; i++)
9180     {
9181       pko obj = list[i].data;
9182       if(is_applicative(obj))
9183         {
9184           kernel_define (print_lookup_unwraps,
9185                          mk_symbol (list[i].name),
9186                          unwrap(0,obj));
9187         }
9188       pko xary = k_to_trivpred(obj);
9189       if((xary != K_NIL) && xary != obj)
9190         {
9191           kernel_define (print_lookup_to_xary,
9192                          mk_symbol (list[i].name),
9193                          xary);
9194         }
9195     }
9196 }
9197
9198 /*_   , make-kernel-standard-environment */
9199 /* Though it would be neater for this to define ground environment if
9200    there is none, that would mean it would need the eval loop and so
9201    couldn't be done early.  So it relies on the ground environment
9202    being already defined.  */
9203 RGSTR(ground,"make-kernel-standard-environment", REF_OPER(mk_std_environment))
9204 DEF_CFUNC(p00a0, mk_std_environment, K_NO_TYPE,T_NO_K)
9205 {
9206   assert(ground_env);
9207   return make_new_frame(ground_env);
9208 }
9209
9210 /*_  . The eval cycle */
9211 /*_   , Helpers */
9212 /*_    . Make an error continuation */
9213 static void
9214 klink_record_error_cont (klink * sc, pko error_continuation)
9215 {
9216   /* Record error continuation. */
9217   kernel_define (sc->envir,
9218                  mk_symbol ("error-continuation"),
9219                  error_continuation);
9220   /* Also record it in interpreter, so built-ins can see it w/o
9221      lookup. */
9222   sc->error_continuation = error_continuation;
9223 }
9224
9225 /*_   , Entry points */
9226 /*_    . Eval cycle that restarts on error */
9227 static void
9228 klink_cycle_restarting (klink * sc, pko combiner)
9229 {
9230   assert(is_combiner(combiner));
9231   assert(is_environment(sc->envir));
9232   /* Arrange to stop if we ever reach where we started. */
9233   klink_push_cont (sc, REF_OPER (k_quit));
9234
9235   /* Grab root continuation. */
9236   kernel_define (sc->envir,
9237                  mk_symbol ("root-continuation"),
9238                  current_continuation (sc));
9239
9240   /* Make main continuation */
9241   klink_push_cont (sc, combiner);
9242
9243   /* Make error continuation on top of main continuation. */
9244   pko error_continuation =
9245     extend_continuation_aux(sc->dump, REF_OPER(kernel_err), sc->envir);
9246
9247   klink_record_error_cont(sc, error_continuation);
9248
9249   /* Conceptually sc->retcode is a keyed dynamic variable that
9250      kernel_err sets. */
9251   sc->retcode = 0;
9252   _klink_cycle (sc);
9253   /* $$RECONSIDER ME Maybe indicate quit value  */
9254 }
9255 /*_    . Eval cycle that terminates on error */
9256 static int
9257 klink_cycle_no_restart (klink * sc, pko combiner)
9258 {
9259   assert(is_combiner(combiner));
9260   assert(is_environment(sc->envir));
9261   /* Arrange to stop if we ever reach where we started. */
9262   klink_push_cont (sc, REF_OPER (k_quit));
9263
9264   /* Grab root continuation. */
9265   kernel_define (sc->envir,
9266                  mk_symbol ("root-continuation"),
9267                  current_continuation (sc));
9268
9269   /* Make error continuation that quits. */
9270   pko error_continuation =
9271     extend_continuation_aux(sc->dump, REF_OPER(kernel_err_return), sc->envir);
9272
9273   klink_record_error_cont(sc, error_continuation);
9274
9275   klink_push_cont (sc, combiner);
9276
9277   /* Conceptually sc->retcode is a keyed dynamic variable that
9278      kernel_err sets.  Actually it's entirely cached in the
9279      interpreter. */
9280   sc->retcode = 0;
9281   _klink_cycle (sc);
9282   return sc->retcode;
9283 }
9284
9285 /*_   , _klink_cycle (Don't use this directly) */
9286 static void
9287 _klink_cycle (klink * sc)
9288 {
9289   pko value = K_INERT;
9290
9291   sc->done = 0;
9292   while (!sc->done)
9293     {
9294       int i = setjmp (sc->pseudocontinuation);
9295       if (i == 0)
9296         {
9297           k_profiling_step();
9298           int got_new_frame = klink_pop_cont (sc);
9299           /* $$RETHINK ME  Is this test still needed?  Could be just
9300              an assertion. */
9301           if (got_new_frame)
9302             {
9303               /* $$IMPROVE ME Instead, a function that governs
9304                  whether to eval. */
9305               if (sc->new_tracing)
9306                 {
9307                   if(_get_type( sc->next_func ) == T_NOTRACE )
9308                     {
9309                       sc->next_func = notrace_comb( sc->next_func );
9310                       goto normal;
9311                     }
9312                   pko tracing =
9313                        klink_find_dyn_binding(sc, K_TRACING );
9314                   /* Now we know the other branch should have been
9315                      taken. */
9316                   if( !tracing || ( tracing == K_F ))
9317                     { goto normal; }
9318
9319                   /* Enqueue a version that will execute without
9320                      tracing.  Its descendants will be traced. */
9321                   CONTIN_0_RAW (mk_notrace(mk_curried(dcrry_1dotALL,
9322                                                       value,
9323                                                       mk_notrace(sc->next_func))),
9324                                  sc );
9325                   switch (_get_type (sc->next_func))
9326                     {
9327                     case T_LOAD:
9328                       putstr (sc, "\nLoad ");
9329                       break;
9330
9331                     case T_STORE:
9332                       putstr (sc, "\nStore ");
9333                       break;
9334
9335                     case T_CURRIED:
9336                       putstr (sc, "\nDecurry ");
9337                       break;
9338
9339                     default:
9340                       /* Print tracing */
9341                       {
9342                         /* Find and print current frame depth */
9343                         int depth = curr_frame_depth (sc->dump);
9344                         char * str = sc->strbuff;
9345                         snprintf (str, STRBUFFSIZE, "\n%d: ", depth);
9346                         putstr (sc, str);
9347                       }
9348                       klink_push_dyn_binding (sc, K_TRACING, K_F);
9349                       putstr (sc, "Eval: ");
9350                       value = kernel_print_sexp (sc,
9351                                                  cons (sc->next_func, value),
9352                                                  K_INERT);
9353                     }
9354                 }
9355               else
9356                 {
9357                 normal:
9358                   value = kernel_eval_aux (sc, sc->next_func, value, sc->envir);
9359                 }
9360
9361             }
9362           /* Stop looping if stack is empty. */
9363           else
9364             { break; }
9365         }
9366       else
9367         /* Otherwise something jumped to a continuation.  Get the
9368            value and keep looping.  */
9369         {
9370           value = sc->value;
9371         }
9372     }
9373   /* In case we're called nested in another _klink_cycle, don't
9374      affect it. */
9375   sc->done = 0;
9376 }
9377
9378 /*_  . Vtable interface */
9379 /* initialization of Klink */
9380 #if USE_INTERFACE
9381
9382 static struct klink_interface vtbl =
9383   {
9384     klink_define,
9385     mk_mutable_pair,
9386     mk_pair,
9387     mk_integer,
9388     mk_real,
9389     mk_symbol,
9390     mk_string,
9391     mk_counted_string,
9392     mk_character,
9393     mk_vector,
9394     putstr,
9395     putcharacter,
9396
9397     is_string,
9398     string_value,
9399     is_number,
9400     nvalue,
9401     ivalue,
9402     rvalue,
9403     is_integer,
9404     is_real,
9405     is_character,
9406     charvalue,
9407     is_finite_list,
9408     is_vector,
9409     list_length,
9410     vector_len,
9411     fill_vector,
9412     vector_elem,
9413     set_vector_elem,
9414     is_port,
9415
9416     is_pair,
9417     pair_car,
9418     pair_cdr,
9419     set_car,
9420     set_cdr,
9421
9422     is_symbol,
9423     symname,
9424
9425     is_continuation,
9426     is_environment,
9427     is_immutable,
9428     setimmutable,
9429
9430     klink_load_file,
9431     klink_load_string,
9432   };
9433 #if USE_DL
9434 /* $$MOVE ME  Later after I separate some headers
9435    This belongs in dynload.c, could be just:
9436    SIG_CHKARRAY(klink_load_ext) = { REF_OPER(is_string), };
9437    DEF_SIMPLE_APPLICATIVE(ps0a1,klink_load_ext,0,ground, "load-extension") {...}
9438  */
9439 RGSTR(ground, "load-extension", REF_APPL(klink_load_ext))
9440 SIG_CHKARRAY(klink_load_ext) = { REF_OPER(is_string), };
9441 DEF_SIMPLE_DESTR(klink_load_ext);
9442 DEF_CFUNC_PSYCNAME(ps0a1,klink_load_ext, REF_DESTR(klink_load_ext),0);
9443 DEF_BOXED_APPLICATIVE(klink_load_ext, REF_OPER (klink_load_ext));
9444
9445 #endif
9446
9447 #endif
9448
9449 /*_  . Initializing Klink */
9450 /*_   , Allocate and initialize */
9451
9452 klink *
9453 klink_alloc_init (FILE * in, FILE * out)
9454 {
9455   klink *sc = (klink *) GC_MALLOC (sizeof (klink));
9456   if (!klink_init (sc, in, out))
9457     {
9458       GC_FREE (sc);
9459       return 0;
9460     }
9461   else
9462     {
9463       return sc;
9464     }
9465 }
9466
9467 /*_   , Initialization without allocation */
9468 int
9469 klink_init (klink * sc, FILE * in, FILE * out)
9470 {
9471   /* Init stack first, just in case something calls _klink_error_1. */
9472   dump_stack_initialize (sc);
9473   /* Initialize ports early in case something prints. */
9474   /* $$IMPROVE ME  Should accept general ports of appropriate in/out. */
9475   klink_set_input_port_file (sc, in);
9476   klink_set_output_port_file (sc, out);
9477
9478 #if USE_INTERFACE
9479   /* Why do we need this field if there is a static table? */
9480   sc->vptr = &vtbl;
9481 #endif
9482
9483   sc->tracing = 0;
9484   sc->new_tracing = 0;
9485
9486   if(!oblist)
9487     { oblist = oblist_initial_value (); }
9488
9489
9490   /* Add the Kernel built-ins */
9491   if(!print_lookup_env)
9492     {
9493       print_lookup_env = K_REGSTRS_TO_ENV(print_lookup_rgsts);
9494     }
9495   if(!all_builtins_env)
9496     {
9497       all_builtins_env = K_REGSTRS_TO_ENV(all_builtins);
9498     }
9499   if(!typecheck_env_syms)
9500     { typecheck_env_syms = K_REGSTRS_TO_ENV(typecheck_syms_rgsts); }
9501   if(!ground_env)
9502     {
9503       /** Register objects from hard-coded list. **/
9504       ground_env = K_REGSTRS_TO_ENV(preregister);
9505       /* $$TRANSITIONAL  Set up special lookup tables related to preregister. */
9506       setup_print_secondary_lookup();
9507       /** Bind certain objects that we make at init time.  **/
9508       kernel_define (ground_env,
9509                      mk_symbol ("print-lookup-env"),
9510                      print_lookup_env);
9511       kernel_define (unsafe_env,
9512                      mk_symbol ("typecheck-special-syms"),
9513                      typecheck_env_syms);
9514
9515       /** Read some definitions from a prolog **/
9516       /* We need an envir before klink_call, because that defines a
9517          few things.  Those bindings are specific to one instance of
9518          the interpreter so they do not belong in anything shared such
9519          as ground_env.  */
9520       /* $$IMPROVE ME Something in the call chain (klink_call?) should
9521          guarantee an environment.  Needn't have anything in it to
9522          begin with.  */
9523       sc->envir = make_new_frame(K_NIL);
9524
9525       /* Can't easily merge this with klink_load_named_file.  Two
9526          difficulties: it uses klink_cycle_restarting while klink_call
9527          uses klink_cycle_no_restart, and here we need to control the
9528          load environment.  */
9529       pko p = port_from_filename (InitFile, port_file | port_input);
9530       if (p == K_NIL) { return 0; }
9531
9532       /* We can't use k_get_mod_fm_port to manage parameters because
9533          later we will need the environment to have several parents:
9534          ground, simple, unsafe, possibly more. */
9535       /* Params: `into' =  ground environment */
9536       /* We can't share this with the previous frame-making, because
9537          it should not define in the same environment.  */
9538       pko params = make_new_frame(K_NIL);
9539       kernel_define (params, mk_symbol ("into"), ground_env);
9540       pko env = make_new_frame(ground_env);
9541       kernel_define (env, mk_symbol ("module-parameters"), params);
9542       int retcode = klink_call(sc,
9543                                REF_OPER(load_from_port),
9544                                LIST2(p, env));
9545       if(retcode) { return 0; }
9546
9547       /* The load will have written various things into ground
9548          environment.  sc->envir is unsuitable now because it is this
9549          load's environment. */
9550     }
9551
9552   assert (is_environment (ground_env));
9553   sc->envir = make_new_frame(ground_env);
9554
9555 #if 1                           /* Transitional.  Leave this on for the moment */
9556   /* initialization of global pointers to special symbols */
9557   sc->QUOTE = mk_symbol ("quote");
9558   sc->QQUOTE = mk_symbol ("quasiquote");
9559   sc->UNQUOTE = mk_symbol ("unquote");
9560   sc->UNQUOTESP = mk_symbol ("unquote-splicing");
9561   sc->COLON_HOOK = mk_symbol ("*colon-hook*");
9562   sc->SHARP_HOOK = mk_symbol ("*sharp-hook*");
9563 #endif
9564   return 1;
9565 }
9566
9567 /*_   , Deinit */
9568 void
9569 klink_deinit (klink * sc)
9570 {
9571   sc->envir = K_NIL;
9572   sc->value = K_NIL;
9573 }
9574 /*_  . Using Klink from C */
9575 /*_   , To set ports */
9576 void
9577 klink_set_input_port_file (klink * sc, FILE * fin)
9578 {
9579   klink_push_dyn_binding(sc,K_INPORT,port_from_file (fin, port_input));
9580 }
9581
9582 void
9583 klink_set_input_port_string (klink * sc, char *start, char *past_the_end)
9584 {
9585   klink_push_dyn_binding(sc,
9586                          K_INPORT,
9587                          port_from_string (start, past_the_end, port_input));
9588 }
9589
9590 void
9591 klink_set_output_port_file (klink * sc, FILE * fout)
9592 {
9593   klink_push_dyn_binding(sc,K_OUTPORT,port_from_file (fout, port_output));
9594 }
9595
9596 void
9597 klink_set_output_port_string (klink * sc, char *start, char *past_the_end)
9598 {
9599   klink_push_dyn_binding(sc,
9600                          K_OUTPORT,
9601                          port_from_string (start, past_the_end, port_output));
9602 }
9603 /*_   , To set external data */
9604 void
9605 klink_set_external_data (klink * sc, void *p)
9606 {
9607   sc->ext_data = p;
9608 }
9609
9610
9611 /*_   , To load */
9612 /*_    . Load file (C) */
9613 /*_     , Worker */
9614 void
9615 klink_load_port (klink * sc, pko p, int interactive)
9616 {
9617   if (p == K_NIL)
9618     {
9619       sc->retcode = 2;
9620       return;
9621     }
9622   else
9623     {
9624       klink_push_dyn_binding(sc,K_INPORT,p);
9625     }
9626
9627   {
9628     pko combiner =
9629       interactive ?
9630       REF_OPER (kernel_repl) :
9631       REF_OPER (kernel_rel);
9632     klink_cycle_restarting (sc, combiner);
9633   }
9634 }
9635
9636 /*_     , klink_load_file */
9637 void
9638 klink_load_file (klink * sc, FILE * fin)
9639 {
9640   klink_load_port (sc,
9641                    port_from_file (fin, port_file | port_input),
9642                    (fin == stdin));
9643 }
9644
9645 /*_     , klink_load_named_file */
9646 void
9647 klink_load_named_file (klink * sc, FILE * fin, const char *filename)
9648 {
9649   klink_load_port(sc,
9650                   port_from_filename (filename, port_file | port_input),
9651                   (fin == stdin));
9652 }
9653
9654 /*_    . load string (C) */
9655
9656 void
9657 klink_load_string (klink * sc, const char *cmd)
9658 {
9659   klink_load_port(sc,
9660                   port_from_string ((char *)cmd,
9661                                     (char *)cmd + strlen (cmd),
9662                                     port_input | port_string),
9663                   0);
9664 }
9665
9666 /*_   , Apply combiner */
9667 /* sc is presumed to be already set up.
9668    The final value or error argument is in sc->value.
9669    The return code is duplicated in sc->retcode.
9670  */
9671 int
9672 klink_call (klink * sc, pko func, pko args)
9673 {
9674   klink_cycle_no_restart (sc,
9675                           mk_curried(dcrry_NdotALL,args,func));
9676   return sc->retcode;
9677 }
9678
9679 /*_   , Eval form */
9680 /* This is completely unexercised. */
9681
9682 int
9683 klink_eval (klink * sc, pko obj)
9684 {
9685   klink_cycle_no_restart(sc,
9686                          mk_curried(dcrry_2dotALL,
9687                                     LIST2(obj,sc->envir),
9688                                     REF_OPER(kernel_eval)));
9689   return sc->retcode;
9690 }
9691
9692 /*_  . Main (if standalone) */
9693 #if STANDALONE
9694 /*_   , Mac */
9695 #if defined(__APPLE__) && !defined (OSX)
9696 int
9697 main ()
9698 {
9699   extern MacTS_main (int argc, char **argv);
9700   char **argv;
9701   int argc = ccommand (&argv);
9702   MacTS_main (argc, argv);
9703   return 0;
9704 }
9705
9706 /*_   , General */
9707 int
9708 MacTS_main (int argc, char **argv)
9709 {
9710 #else
9711 int
9712 main (int argc, char **argv)
9713 {
9714 #endif
9715   klink sc;
9716   FILE *fin = 0;
9717   char *file_name = 0;          /* Was InitFile */
9718   int retcode;
9719   int isfile = 1;
9720   GC_INIT ();
9721   if (argc == 1)
9722     {
9723       printf (banner);
9724     }
9725   if (argc == 2 && strcmp (argv[1], "-?") == 0)
9726     {
9727       printf ("Usage: klink -?\n");
9728       printf ("or:    klink [<file1> <file2> ...]\n");
9729       printf ("followed by\n");
9730       printf ("          -1 <file> [<arg1> <arg2> ...]\n");
9731       printf ("          -c <Kernel commands> [<arg1> <arg2> ...]\n");
9732       printf ("assuming that the executable is named klink.\n");
9733       printf ("Use - as filename for stdin.\n");
9734       return 1;
9735     }
9736
9737   /* Make error_continuation semi-safe until it's properly set.  */
9738   sc.error_continuation = 0;
9739   int i = setjmp (sc.pseudocontinuation);
9740   if (i == 0)
9741     {
9742       if (!klink_init (&sc, stdin, stdout))
9743         {
9744           fprintf (stderr, "Could not initialize!\n");
9745           return 2;
9746         }
9747     }
9748   else
9749     {
9750       fprintf (stderr, "Kernel error encountered while initializing!\n");
9751       return 3;
9752     }
9753   argv++;
9754   /* $$IMPROVE ME Maybe use get_opts instead. */
9755   while(1)
9756     {
9757       /* $$IMPROVE ME Add a principled way of sometimes including
9758          filename defined in environment.  Eg getenv
9759          ("KLINKINIT").  */
9760       file_name = *argv;
9761       argv++;
9762       if(!file_name) { break; }
9763       if (strcmp (file_name, "-") == 0)
9764         {
9765           fin = stdin;
9766         }
9767       else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
9768         {
9769           pko args = K_NIL;
9770           /* $$FACTOR ME This is a messy way to distinguish command
9771              string from filename string */
9772           isfile = (file_name[1] == '1');
9773           file_name = *argv++;
9774           if (strcmp (file_name, "-") == 0)
9775             {
9776               fin = stdin;
9777             }
9778           else if (isfile)
9779             {
9780               fin = fopen (file_name, "r");
9781             }
9782
9783           /* Put remaining command-line args into *args* in envir. */
9784           for (; *argv; argv++)
9785             {
9786               pko value = mk_string (*argv);
9787               args = mcons (value, args);
9788             }
9789           args = unsafe_v2reverse_in_place (K_NIL, args);
9790           /* Instead, use (command-line) as accessor and provide the
9791              whole command line as a list of strings.  */
9792           kernel_define (sc.envir, mk_symbol ("*args*"), args);
9793
9794         }
9795       else
9796         {
9797           fin = fopen (file_name, "r");
9798         }
9799       if (isfile && fin == 0)
9800         {
9801           fprintf (stderr, "Could not open file %s\n", file_name);
9802         }
9803       else
9804         {
9805           if (isfile)
9806             {
9807               /* $$IMPROVE ME Use klink_load_named_file, replacing the
9808                  file-opening code, so we can report filename  */
9809               klink_load_file (&sc, fin);
9810             }
9811           else
9812             {
9813               klink_load_string (&sc, file_name);
9814             }
9815           if (!isfile || fin != stdin)
9816             {
9817               if (sc.retcode != 0)
9818                 {
9819                   fprintf (stderr, "Errors encountered reading %s\n",
9820                            file_name);
9821                 }
9822               if (isfile)
9823                 {
9824                   fclose (fin);
9825                 }
9826             }
9827         }
9828     }
9829
9830   if (argc == 1)
9831     {
9832       /* $$MAKE ME CLEANER Quick and dirty for now, we make an
9833          environment for this but let everything else modify ground
9834          env.  I'd like to be more correct about that. */
9835       /* Make an interactive environment over ground_env. */
9836       new_frame_in_env (&sc, sc.envir);
9837       klink_load_file (&sc, stdin);
9838     }
9839   retcode = sc.retcode;
9840   klink_deinit (&sc);
9841
9842   return retcode;
9843 }
9844
9845 #endif
9846
9847 /*_ , Footers */
9848 /*
9849 Local variables:
9850 c-file-style: "gnu"
9851 mode: allout
9852 End:
9853 */