mes.c

   1 /*
   2  * Mes --- Maxwell Equations of Software
   3  * Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   4  *
   5  * This file is part of Mes.
   6  *
   7  * Mes is free software; you can redistribute it and/or modify it
   8  * under the terms of the GNU General Public License as published by
   9  * the Free Software Foundation; either version 3 of the License, or (at
  10  * your option) any later version.
  11  *
  12  * Mes is distributed in the hope that it will be useful, but
  13  * WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  19  */
  20
  21 // (setq comment-start "//")
  22 // (setq comment-end "")
  23 /*
  24  * The Maxwell Equations of Software -- John McCarthy page 13
  25  * http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
  26  */
  27
  28 #define _GNU_SOURCE
  29 #include <assert.h>
  30 #include <ctype.h>
  31 #include <stdarg.h>
  32 #include <stdio.h>
  33 #include <string.h>
  34 #include <stdlib.h>
  35 #include <stdbool.h>
  36
  37 #define DEBUG 0
  38
  39 #define MACROS 1
  40 #define QUASIQUOTE 1
  41
  42 #ifndef QUOTE_SUGAR
  43 #define QUOTE_SUGAR 1
  44 #endif
  45
  46 enum type {ATOM, NUMBER, PAIR, FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3};
  47 struct scm_t;
  48 typedef struct scm_t* (*function0_t) (void);
  49 typedef struct scm_t* (*function1_t) (struct scm_t*);
  50 typedef struct scm_t* (*function2_t) (struct scm_t*, struct scm_t*);
  51 typedef struct scm_t* (*function3_t) (struct scm_t*, struct scm_t*, struct scm_t*);
  52
  53 typedef struct scm_t {
  54   enum type type;
  55   union {
  56     char *name;
  57     struct scm_t* car;
  58   };
  59   union {
  60     int value;
  61     function0_t function0;
  62     function1_t function1;
  63     function2_t function2;
  64     function3_t function3;
  65     struct scm_t* cdr;
  66   };
  67 } scm;
  68
  69 scm scm_nil = {ATOM, "()"};
  70 scm scm_dot = {ATOM, "."};
  71 scm scm_t = {ATOM, "#t"};
  72 scm scm_f = {ATOM, "#f"};
  73 scm scm_lambda = {ATOM, "lambda"};
  74 scm scm_label = {ATOM, "label"};
  75 scm scm_unspecified = {ATOM, "*unspecified*"};
  76 scm scm_symbol_cond = {ATOM, "cond"};
  77 scm scm_symbol_quote = {ATOM, "quote"};
  78 #if QUASIQUOTE
  79 scm scm_symbol_quasiquote = {ATOM, "quasiquote"};
  80 scm scm_symbol_unquote = {ATOM, "unquote"};
  81 #endif
  82 #if MACROS
  83 scm scm_macro = {ATOM, "*macro*"};
  84 #endif
  85 scm scm_symbol_current_module = {ATOM, "current-module"};
  86
  87 // PRIMITIVES
  88
  89 scm *
  90 atom_p (scm *x)
  91 {
  92   return x->type == PAIR ? &scm_f : &scm_t;
  93 }
  94 scm scm_atom = {FUNCTION1, .name="atom", .function1 = &atom_p};
  95
  96 scm *
  97 car (scm *x)
  98 {
  99   assert (x->type == PAIR);
 100   return x->car;
 101 }
 102
 103 scm *
 104 cdr (scm *x)
 105 {
 106   assert (x->type == PAIR);
 107   return x->cdr;
 108 }
 109
 110 scm *
 111 cons (scm *x, scm *y)
 112 {
 113   scm *p = malloc (sizeof (scm));
 114   p->type = PAIR;
 115   p->car = x;
 116   p->cdr = y;
 117   return p;
 118 }
 119
 120 scm *
 121 eq_p (scm *x, scm *y)
 122 {
 123   return (x == y
 124           || (x->type == NUMBER && y->type == NUMBER
 125               && x->value == y->value)
 126           // FIXME: alist lookup symbols
 127           || (atom_p (x) == &scm_t
 128               && x->type != NUMBER
 129               && y->type != NUMBER
 130               && atom_p (y) == &scm_t
 131               && !strcmp (x->name, y->name)))
 132     ? &scm_t : &scm_f;
 133 }
 134
 135 scm *
 136 null_p (scm *x)
 137 {
 138   return eq_p (x, &scm_nil);
 139 }
 140
 141 scm *
 142 pair_p (scm *x)
 143 {
 144   return x->type == PAIR ? &scm_t : &scm_f;
 145 }
 146
 147 scm *eval (scm*, scm*);
 148
 149 scm *display (scm*);
 150
 151 scm scm_quote;
 152 scm *
 153 quote (scm *x)
 154 {
 155   return cons (&scm_quote, x);
 156 }
 157
 158 #if QUASIQUOTE
 159 scm scm_unquote;
 160 scm *
 161 unquote (scm *x)
 162 {
 163   return cons (&scm_unquote, x);
 164 }
 165
 166 scm scm_quasiquote;
 167 scm *
 168 quasiquote (scm *x)
 169 {
 170   return cons (&scm_quasiquote, x);
 171 }
 172
 173 scm *eval_quasiquote (scm *, scm *);
 174
 175 #endif
 176
 177 //Library functions
 178 scm scm_read;
 179
 180
 181 // Derived, non-primitives
 182 scm *caar (scm *x) {return car (car (x));}
 183 scm *cadr (scm *x) {return car (cdr (x));}
 184 scm *cdar (scm *x) {return cdr (car (x));}
 185 scm *cddr (scm *x) {return cdr (cdr (x));}
 186 scm *caadr (scm *x) {return car (car (cdr (x)));}
 187 scm *caddr (scm *x) {return car (cdr (cdr (x)));}
 188 scm *cdadr (scm *x) {return cdr (car (cdr (x)));}
 189 scm *cadar (scm *x) {return car (cdr (car (x)));}
 190 scm *cddar (scm *x) {return cdr (cdr (car (x)));}
 191 scm *cdddr (scm *x) {return cdr (cdr (cdr (x)));}
 192 scm scm_caar  = {FUNCTION1, .name="caar ", .function1 = &caar };
 193 scm scm_cadr  = {FUNCTION1, .name="cadr ", .function1 = &cadr };
 194 scm scm_cdar  = {FUNCTION1, .name="cdar ", .function1 = &cdar };
 195 scm scm_cddr  = {FUNCTION1, .name="cddr ", .function1 = &cddr };
 196 scm scm_caadr = {FUNCTION1, .name="caadr", .function1 = &caadr};
 197 scm scm_caddr = {FUNCTION1, .name="caddr", .function1 = &caddr};
 198 scm scm_cdadr = {FUNCTION1, .name="cdadr", .function1 = &cdadr};
 199 scm scm_cadar = {FUNCTION1, .name="cadar", .function1 = &cadar};
 200 scm scm_cddar = {FUNCTION1, .name="cddar", .function1 = &cddar};
 201 scm scm_cdddr = {FUNCTION1, .name="cdddr", .function1 = &cdddr};
 202
 203 scm *
 204 list (scm *x, ...)
 205 {
 206   va_list args;
 207   scm *lst = &scm_nil;
 208
 209   va_start (args, x);
 210   while (x != &scm_unspecified)
 211     {
 212       lst = cons (x, lst);
 213       x = va_arg (args, scm*);
 214     }
 215   va_end (args);
 216   return lst;
 217 }
 218
 219 scm* make_atom (char const *);
 220
 221 scm *
 222 pairlis (scm *x, scm *y, scm *a)
 223 {
 224 #if DEBUG
 225   printf ("pairlis x=");
 226   display (x);
 227   printf (" y=");
 228   display (y);
 229   puts ("");
 230 #endif
 231   if (x == &scm_nil)
 232     return a;
 233   if (atom_p (x) == &scm_t)
 234     return cons (cons (x, y), a);
 235   return cons (cons (car (x), car (y)),
 236                pairlis (cdr (x), cdr (y), a));
 237 }
 238 scm scm_pairlis = {FUNCTION3, .name="pairlis", .function3 = &pairlis};
 239
 240 scm *
 241 assoc (scm *x, scm *a)
 242 {
 243   if (a == &scm_nil) {
 244 #if DEBUG
 245     printf ("alist miss: %s\n", x->name);
 246 #endif
 247     return &scm_f;
 248   }
 249   if (eq_p (caar (a), x) == &scm_t)
 250     return car (a);
 251   return assoc (x, cdr (a));
 252 }
 253 scm scm_assoc = {FUNCTION2, .name="assoc", .function2 = &assoc};
 254
 255 scm *apply (scm*, scm*, scm*);
 256 scm *eval_ (scm*, scm*);
 257 scm *apply_ (scm*, scm*, scm*);
 258
 259 scm *
 260 eval_quote (scm *fn, scm *x)
 261 {
 262   return apply (fn, x, &scm_nil);
 263 }
 264
 265 scm *builtin_p (scm*);
 266 scm *call (scm *, scm*);
 267 scm *display (scm*);
 268 scm *newline ();
 269
 270 scm *
 271 apply_ (scm *fn, scm *x, scm *a)
 272 {
 273 #if DEBUG
 274   printf ("apply fn=");
 275   display (fn);
 276   printf (" x=");
 277   display (x);
 278   puts ("");
 279 #endif
 280   if (atom_p (fn) != &scm_f)
 281     {
 282       if (fn == &scm_symbol_current_module) // FIXME
 283         return a;
 284       if (builtin_p (fn) == &scm_t)
 285         return call (fn, x);
 286       return apply (eval (fn,  a), x, a);
 287     }
 288   else if (car (fn) == &scm_lambda) {
 289     scm *body = cddr (fn);
 290     scm *ca = cadr (fn);
 291     scm *ax = pairlis (cadr (fn), x, a);
 292     scm *result = eval (car (body), ax);
 293     if (cdr (body) == &scm_nil)
 294       return result;
 295     return apply (cons (car (fn), cons (cadr (fn), cdddr (fn))), x, ax);
 296   }
 297   else if (car (fn) == &scm_label)
 298     return apply (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
 299   return &scm_unspecified;
 300 }
 301
 302 scm *evcon (scm*, scm*);
 303 scm *evlis (scm*, scm*);
 304
 305 scm *
 306 eval_ (scm *e, scm *a)
 307 {
 308 #if DEBUG
 309   printf ("eval e=");
 310   display (e);
 311   puts ("");
 312 #endif
 313   if (e->type == NUMBER)
 314     return e;
 315   else if (atom_p (e) == &scm_t) {
 316     scm *y = assoc (e, a);
 317     if (y == &scm_f) {
 318       printf ("eval: no such symbol: %s\n", e->name);
 319       exit (1);
 320     }
 321     return cdr (y);
 322   }
 323   if (builtin_p (e) == &scm_t)
 324     return e;
 325   else if (atom_p (car (e)) == &scm_t)
 326     {
 327 #if MACROS
 328       scm *macro;
 329 #endif // MACROS
 330       if (car (e) == &scm_symbol_quote)
 331         return cadr (e);
 332       if (car (e) == &scm_lambda)
 333         return e;
 334 #if QUASIQUOTE
 335       else if (car (e) == &scm_symbol_unquote)
 336         return eval (cadr (e), a);
 337       else if (car (e) == &scm_symbol_quasiquote) {
 338 #if DEBUG
 339         printf ("cadr e:");
 340         display (cadr (e));
 341         puts ("");
 342         printf ("qq:");
 343         display (eval_quasiquote (cadr (e), a));
 344         puts ("");
 345 #endif // DEBUG
 346         return eval_quasiquote (cadr (e), a);
 347       }
 348 #endif // QUASIQUOTE
 349       else if (car (e) == &scm_symbol_cond)
 350         return evcon (cdr (e), a);
 351 #if MACROS
 352       else if ((macro = assoc (car (e), cdr (assoc (&scm_macro, a)))) != &scm_f)
 353         return eval (apply_ (cdr (macro), cdr (e), a), a);
 354 #endif // MACROS
 355       return apply (car (e), evlis (cdr (e), a), a);
 356     }
 357   return apply (car (e), evlis (cdr (e), a), a);
 358 }
 359
 360 scm *
 361 evcon_ (scm *c, scm *a)
 362 {
 363 #if DEBUG
 364   printf ("evcon_ clause=");
 365   display (car (c));
 366   puts ("");
 367 #endif
 368   if (eval (caar (c), a) != &scm_f) {
 369 #if DEBUG
 370     //if (fn != &scm_display && fn != &scm_call)
 371     //if (fn != &scm_call)
 372     printf ("#t clause=");
 373     display (car (c));
 374     printf (" cddar=");
 375     display (cddar (c));
 376     printf (" nil=%d", cddar (c) == &scm_nil);
 377     puts ("");
 378 #endif
 379     if (cddar (c) == &scm_nil)
 380       return eval (cadar (c), a);
 381     eval (cadar (c), a);
 382     return evcon_ (cons (cons (&scm_t, cddar (c)), &scm_nil), a);
 383   }
 384   return evcon_ (cdr (c), a);
 385 }
 386
 387 scm *
 388 evcon (scm *c, scm *a)
 389 {
 390 #if DEBUG
 391   printf ("\n****evcon=");
 392   display (c);
 393   puts ("");
 394 #endif
 395   return evcon_ (c, a);
 396 }
 397
 398 scm scm_evcon = {FUNCTION2, .name="evcon", .function2 = &evcon};
 399
 400 scm *
 401 evlis (scm *m, scm *a)
 402 {
 403 #if DEBUG
 404   printf ("evlis m=");
 405   display (m);
 406   puts ("");
 407 #endif
 408   if (m == &scm_nil)
 409     return &scm_nil;
 410   scm *e = eval (car (m), a);
 411   return cons (e, evlis (cdr (m), a));
 412 }
 413 scm scm_evlis = {FUNCTION2, .name="evlis", .function2 = &evlis};
 414
 415
 416 //Primitives
 417 scm scm_car = {FUNCTION1, "car", .function1 = &car};
 418 scm scm_cdr = {FUNCTION1, "cdr", .function1 = &cdr};
 419 scm scm_cons = {FUNCTION2, "cons", .function2 = &cons};
 420 scm scm_cond = {FUNCTION2, "cond", .function2 = &evcon};
 421 scm scm_eq_p = {FUNCTION2, "eq", .function2 = &eq_p};
 422 scm scm_null_p = {FUNCTION1, "null", .function1 = &null_p};
 423 scm scm_pair_p = {FUNCTION1, "pair", .function1 = &pair_p};
 424 scm scm_quote = {FUNCTION1, "quote", .function1 = &quote};
 425
 426 #if QUASIQUOTE
 427 scm scm_unquote = {FUNCTION1, "unquote", .function1 = &unquote};
 428 scm scm_quasiquote = {FUNCTION1, "quasiquote", .function1 = &quasiquote};
 429 #endif
 430
 431 scm scm_eval = {FUNCTION2, .name="eval", .function2 = &eval};
 432 scm scm_apply = {FUNCTION3, .name="apply", .function3 = &apply};
 433
 434 scm scm_apply_ = {FUNCTION3, .name="c:apply", .function3 = &apply_};
 435 scm scm_eval_ = {FUNCTION2, .name="c:eval", .function2 = &eval_};
 436
 437 //Helpers
 438
 439 scm *
 440 builtin_p (scm *x)
 441 {
 442   return (x->type == FUNCTION0
 443           || x->type == FUNCTION1
 444           || x->type == FUNCTION2
 445           || x->type == FUNCTION3)
 446     ? &scm_t : &scm_f;
 447 }
 448 scm scm_builtin_p = {FUNCTION1, .name="builtin", .function1 = &builtin_p};
 449
 450 scm *
 451 number_p (scm *x)
 452 {
 453   return x->type == NUMBER ? &scm_t : &scm_f;
 454 }
 455 scm scm_number_p = {FUNCTION1, .name="number", .function1 = &number_p};
 456
 457 scm *display_helper (scm*, bool, char*, bool);
 458
 459 scm *
 460 display (scm *x)
 461 {
 462   return display_helper (x, false, "", false);
 463 }
 464 scm scm_display = {FUNCTION1, .name="display", .function1 = &display};
 465
 466 scm *call (scm*, scm*);
 467 scm scm_call = {FUNCTION2, .name="call", .function2 = &call};
 468
 469 scm *
 470 call (scm *fn, scm *x)
 471 {
 472 #if DEBUG
 473   //if (fn != &scm_display && fn != &scm_call)
 474   //if (fn != &scm_call)
 475   {
 476     printf ("\ncall fn=");
 477     display (fn);
 478     printf (" x=");
 479     display (x);
 480     puts ("");
 481   }
 482 #endif
 483   if (fn->type == FUNCTION0)
 484     return fn->function0 ();
 485   if (fn->type == FUNCTION1)
 486     return fn->function1 (car (x));
 487   if (fn->type == FUNCTION2)
 488     return fn->function2 (car (x), cadr (x));
 489   if (fn->type == FUNCTION3)
 490     return fn->function3 (car (x), cadr (x), caddr (x));
 491   return &scm_unspecified;
 492 }
 493
 494 scm *
 495 append (scm *x, scm *y)
 496 {
 497   if (x == &scm_nil) return y;
 498   assert (x->type == PAIR);
 499    return cons (car (x), append (cdr (x), y));
 500 }
 501 scm scm_append = {FUNCTION2, .name="append", .function2 = &append};
 502
 503
 504 scm *
 505 make_atom (char const *s)
 506 {
 507   // TODO: alist lookup symbols
 508   scm *p = malloc (sizeof (scm));
 509   p->type = ATOM;
 510   p->name = strdup (s);
 511   return p;
 512 }
 513
 514 scm *
 515 make_number (int x)
 516 {
 517   scm *p = malloc (sizeof (scm));
 518   p->type = NUMBER;
 519   p->value = x;
 520   return p;
 521 }
 522
 523 scm *
 524 lookup (char *x, scm *a)
 525 {
 526   if (isdigit (*x) || (*x == '-' && isdigit (*(x+1))))
 527     return make_number (atoi (x));
 528   if (*x == '\'') return &scm_symbol_quote;
 529
 530   if (!strcmp (x, scm_symbol_cond.name)) return &scm_symbol_cond;
 531   if (!strcmp (x, scm_symbol_quote.name)) return &scm_symbol_quote;
 532   if (!strcmp (x, scm_lambda.name)) return &scm_lambda;
 533   if (!strcmp (x, scm_label.name)) return &scm_label;
 534   if (!strcmp (x, scm_nil.name)) return &scm_nil;
 535
 536 #if QUASIQUOTE
 537   if (*x == '`') return &scm_symbol_quasiquote;
 538   if (*x == ',') return &scm_symbol_unquote;
 539   if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote;
 540   if (!strcmp (x, scm_symbol_quasiquote.name)) return &scm_symbol_quasiquote;
 541 #endif
 542
 543   return make_atom (x);
 544 }
 545
 546 scm *
 547 lookup_char (int c, scm *a)
 548 {
 549   char buf[2];
 550   buf[0] = c;
 551   buf[1] = 0;
 552   return lookup (buf, a);
 553 }
 554
 555 char *
 556 list2str (scm *l)
 557 {
 558   static char buf[256];
 559   char *p = buf;
 560   while (l != &scm_nil) {
 561     scm *c = car (l);
 562     assert (c->type == NUMBER);
 563     *p++ = c->value;
 564     l = cdr (l);
 565   }
 566   *p = 0;
 567   return buf;
 568 }
 569
 570 scm *
 571 builtin_lookup (scm *l, scm *a)
 572 {
 573   return lookup (list2str (l), a);
 574 }
 575 scm scm_lookup = {FUNCTION2, .name="lookup", .function2 = &builtin_lookup};
 576
 577 scm *
 578 cossa (scm *x, scm *a)
 579 {
 580   if (a == &scm_nil) return &scm_f;
 581   if (eq_p (cdar (a), x) == &scm_t)
 582     return car (a);
 583   return cossa (x, cdr (a));
 584 }
 585
 586 scm *
 587 newline ()
 588 {
 589   puts ("");
 590   return &scm_unspecified;
 591 }
 592 scm scm_newline = {FUNCTION0, .name="newline", .function0 = &newline};
 593
 594 scm *
 595 display_helper (scm *x, bool cont, char *sep, bool quote)
 596 {
 597   scm *r;
 598   printf ("%s", sep);
 599   if (x->type == NUMBER) printf ("%d", x->value);
 600   else if (x->type == PAIR) {
 601 #if QUOTE_SUGAR
 602     if (car (x) == &scm_quote) {
 603       printf ("'");
 604       return display_helper (car (cdr (x)), cont, "", true);
 605     }
 606 #if QUASIQUOTE
 607     if (car (x) == &scm_symbol_quasiquote
 608         || car (x) == &scm_quasiquote) {
 609       printf ("`");
 610       return display_helper (car (cdr (x)), cont, "", true);
 611     }
 612     if (car (x) == &scm_symbol_unquote
 613         || car (x) == &scm_unquote) {
 614       printf (",");
 615       return display_helper (car (cdr (x)), cont, "", true);
 616     }
 617 #endif
 618 #endif
 619     if (!cont) printf ("(");
 620     display (car (x));
 621     if (cdr (x)->type == PAIR)
 622       display_helper (cdr (x), true, " ", false);
 623     else if (cdr (x) != &scm_nil) {
 624       printf (" . ");
 625       display (cdr (x));
 626     }
 627     if (!cont) printf (")");
 628   }
 629   else if (atom_p (x) == &scm_t) printf ("%s", x->name);
 630
 631   return &scm_unspecified;
 632 }
 633
 634 // READ
 635
 636 int
 637 ungetchar (int c)
 638 {
 639   return ungetc (c, stdin);
 640 }
 641
 642 int
 643 peekchar ()
 644 {
 645   int c = getchar ();
 646   ungetchar (c);
 647   return c;
 648 }
 649
 650 scm*
 651 builtin_getchar ()
 652 {
 653   return make_number (getchar ());
 654 }
 655 scm scm_getchar = {FUNCTION0, .name="getchar", .function0 = &builtin_getchar};
 656
 657 scm*
 658 builtin_peekchar ()
 659 {
 660   return make_number (peekchar ());
 661 }
 662 scm scm_peekchar = {FUNCTION0, .name="peekchar", .function0 = &builtin_peekchar};
 663
 664 scm*
 665 builtin_ungetchar (scm* c)
 666 {
 667   assert (c->type == NUMBER);
 668   ungetchar (c->value);
 669   return c;
 670 }
 671 scm scm_ungetchar = {FUNCTION1, .name="ungetchar", .function1 = &builtin_ungetchar};
 672
 673 int
 674 readcomment (int c)
 675 {
 676   if (c == '\n') return c;
 677   return readcomment (getchar ());
 678 }
 679
 680 int
 681 readblock (int c)
 682 {
 683   if (c == '!' && peekchar () == '#') return getchar ();
 684   return readblock (getchar ());
 685 }
 686
 687 scm *readlis (scm *a);
 688
 689 scm *
 690 readword (int c, char* w, scm *a)
 691 {
 692   if (c == EOF && !w) return &scm_nil;
 693   if (c == '\n' && !w) return readword (getchar (), w, a);
 694   if (c == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
 695   if (c == EOF || c == '\n') return lookup (w, a);
 696   if (c == ' ') return readword ('\n', w, a);
 697   if (c == '(' && !w) return readlis (a);
 698   if (c == '(') {ungetchar (c); return lookup (w, a);}
 699   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
 700   if (c == ')') {ungetchar (c); return lookup (w, a);}
 701   if ((c == '\''
 702 #if QUASIQUOTE
 703        || c == '`'
 704        || c == ','
 705 #endif
 706        )
 707       && !w) {return cons (lookup_char (c, a),
 708                                      cons (readword (getchar (), w, a),
 709                                            &scm_nil));}
 710   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
 711   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
 712   char buf[256] = {0};
 713   char ch = c;
 714   return readword (getchar (), strncat (w ? w : buf, &ch, 1), a);
 715 }
 716
 717 int
 718 eat_whitespace (int c)
 719 {
 720   while (c == ' ' || c == '\n') c = getchar ();
 721   if (c == ';') return eat_whitespace (readcomment (c));
 722   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return eat_whitespace (getchar ());}
 723   return c;
 724 }
 725
 726 scm *
 727 readlis (scm *a)
 728 {
 729   int c = getchar ();
 730   c = eat_whitespace (c);
 731   if (c == ')') return &scm_nil;
 732   scm *w = readword (c, 0, a);
 733   if (w == &scm_dot)
 734     return car (readlis (a));
 735   return cons (w, readlis (a));
 736 }
 737
 738 scm *
 739 readenv (scm *a)
 740 {
 741   return readword (getchar (), 0, a);
 742 }
 743 scm scm_readenv = {FUNCTION1, .name="readenv", .function1 = &readenv};
 744
 745 // Extras to make interesting program
 746
 747 scm *
 748 hello_world ()
 749 {
 750   puts ("c: hello world");
 751   return &scm_unspecified;
 752 }
 753 scm scm_hello_world = {FUNCTION0, .name="hello-world", .function0 = &hello_world};
 754
 755
 756 scm *
 757 less_p (scm *a, scm *b)
 758 {
 759   assert (a->type == NUMBER);
 760   assert (b->type == NUMBER);
 761   return a->value < b->value ? &scm_t : &scm_f;
 762 }
 763
 764 scm *
 765 minus (scm *a, scm *b)
 766 {
 767 #if DEBUG
 768   printf ("\nminus a=");
 769   display (a);
 770   printf (" b=");
 771   display (b);
 772   puts ("");
 773 #endif
 774   assert (a->type == NUMBER);
 775   assert (b->type == NUMBER);
 776   //return make_number (a->value - b->value);
 777   scm *r = make_number (a->value - b->value);
 778 #if DEBUG
 779   printf ("  ==> ");
 780   display (r);
 781   puts ("");
 782 #endif
 783   return r;
 784 }
 785
 786 scm scm_less_p = {FUNCTION2, .name="<", .function2 = &less_p};
 787 scm scm_minus = {FUNCTION2, .name="-", .function2 = &minus};
 788
 789 #if QUASIQUOTE
 790 scm *
 791 eval_quasiquote (scm *e, scm *a)
 792 {
 793 #if DEBUG
 794   printf ("\nc:eval_quasiquote e=");
 795   display (e);
 796   if (pair_p (e) == &scm_t) {
 797     printf ("\ncar (e)=");
 798     display (car (e));
 799     printf (" atom=");
 800     display (atom_p (car (e)));
 801   }
 802   puts ("");
 803 #endif
 804   if (e == &scm_nil) return e;
 805   else if (atom_p (e) == &scm_t) return e;
 806   else if (atom_p (car (e)) == &scm_t)
 807     return cons (car (e), eval_quasiquote (cdr (e), a));
 808   else if (eq_p (caar (e), &scm_symbol_unquote) == &scm_t)
 809     return cons (eval (cadar (e), a), &scm_nil);
 810   else if (eq_p (caar (e), &scm_symbol_quote) == &scm_t)
 811     return cons (cadar (e), &scm_nil);
 812   else if (eq_p (caar (e), &scm_symbol_quasiquote) == &scm_t)
 813     return cdar (e);
 814   return cons (car (e), eval_quasiquote (cdr (e), a));
 815 }
 816 scm scm_eval_quasiquote = {FUNCTION2, .name="c:eval-quasiquote", .function2 = &eval_quasiquote};
 817 #endif
 818
 819 scm *
 820 add_environment (scm *a, char *name, scm* x)
 821 {
 822   return cons (cons (make_atom (name), x), a);
 823 }
 824
 825 scm *
 826 initial_environment ()
 827 {
 828   scm *a = &scm_nil;
 829
 830   a = add_environment (a, "()", &scm_nil);
 831   a = add_environment (a, "#t", &scm_t);
 832   a = add_environment (a, "#f", &scm_f);
 833   a = add_environment (a, "*unspecified*", &scm_unspecified);
 834
 835   a = add_environment (a, "label", &scm_label);
 836   a = add_environment (a, "lambda", &scm_lambda);
 837
 838   a = add_environment (a, "atom", &scm_atom);
 839   a = add_environment (a, "car", &scm_car);
 840   a = add_environment (a, "cdr", &scm_cdr);
 841   a = add_environment (a, "cons", &scm_cons);
 842   a = add_environment (a, "cond", &scm_cond);
 843   a = add_environment (a, "eq", &scm_eq_p);
 844
 845   a = add_environment (a, "null", &scm_null_p);
 846   a = add_environment (a, "pair", &scm_pair_p);
 847   a = add_environment (a, "quote", &scm_quote);
 848   a = add_environment (a, "'", &scm_quote);
 849
 850 #if QUASIQUOTE
 851   a = add_environment (a, "quasiquote", &scm_quasiquote);
 852   a = add_environment (a, "unquote", &scm_unquote);
 853   a = add_environment (a, ",", &scm_unquote);
 854   a = add_environment (a, "`", &scm_quasiquote);
 855   a = add_environment (a, "eval-quasiquote", &scm_eval_quasiquote);
 856 #endif
 857
 858   a = add_environment (a, "evlis", &scm_evlis);
 859   a = add_environment (a, "evcon", &scm_evcon);
 860   a = add_environment (a, "pairlis", &scm_pairlis);
 861   a = add_environment (a, "assoc", &scm_assoc);
 862
 863   a = add_environment (a, "c:eval", &scm_eval_);
 864   a = add_environment (a, "c:apply", &scm_apply_);
 865   a = add_environment (a, "eval", &scm_eval);
 866   a = add_environment (a, "apply", &scm_apply);
 867
 868   a = add_environment (a, "getchar", &scm_getchar);
 869   a = add_environment (a, "peekchar", &scm_peekchar);
 870   a = add_environment (a, "ungetchar", &scm_ungetchar);
 871   a = add_environment (a, "lookup", &scm_lookup);
 872
 873   a = add_environment (a, "readenv", &scm_readenv);
 874   a = add_environment (a, "display", &scm_display);
 875   a = add_environment (a, "newline", &scm_newline);
 876
 877   a = add_environment (a, "builtin", &scm_builtin_p);
 878   a = add_environment (a, "number", &scm_number_p);
 879   a = add_environment (a, "call", &scm_call);
 880
 881
 882   a = add_environment (a, "hello-world", &scm_hello_world);
 883   a = add_environment (a, "<", &scm_less_p);
 884   a = add_environment (a, "-", &scm_minus);
 885
 886   // DERIVED
 887   a = add_environment (a, "caar", &scm_caar);
 888   a = add_environment (a, "cadr", &scm_cadr);
 889   a = add_environment (a, "cdar", &scm_cdar);
 890   a = add_environment (a, "cddr", &scm_cddr);
 891   a = add_environment (a, "caadr", &scm_caadr);
 892   a = add_environment (a, "caddr", &scm_caddr);
 893   a = add_environment (a, "cdadr", &scm_cdadr);
 894   a = add_environment (a, "cadar", &scm_cadar);
 895   a = add_environment (a, "cddar", &scm_cddar);
 896   a = add_environment (a, "cdddr", &scm_cdddr);
 897
 898   a = add_environment (a, "append", &scm_append);
 899
 900   //
 901   a = add_environment (a, "*macro*", &scm_nil);
 902   a = add_environment (a, "*dot*", &scm_dot);
 903   a = add_environment (a, "current-module", &scm_symbol_current_module);
 904
 905   return a;
 906 }
 907
 908 scm *
 909 define_lambda (scm *x)
 910 {
 911   return cons (caadr (x), cons (&scm_lambda, cons (cdadr (x), cddr (x))));
 912 }
 913
 914 scm *
 915 define (scm *x, scm *a)
 916 {
 917   if (atom_p (cadr (x)) != &scm_f)
 918     return cons (cadr (x), eval (caddr (x), a));
 919   return define_lambda (x);
 920 }
 921
 922 scm *
 923 define_macro (scm *x, scm *a)
 924 {
 925 #if DEBUG
 926   printf ("\nc:define_macro a=");
 927   scm *aa =cons (&scm_macro,
 928                cons (define_lambda (x),
 929                      cdr (assoc (&scm_macro, a))));
 930   display (aa);
 931   puts ("");
 932 #endif
 933   return cons (&scm_macro,
 934                cons (define_lambda (x),
 935                      cdr (assoc (&scm_macro, a))));
 936 }
 937
 938 scm *
 939 loop (scm *r, scm *e, scm *a)
 940 {
 941 #if 0//DEBUG
 942   printf ("\nc:loop e=");
 943   display (e);
 944   puts ("");
 945 #endif
 946   if (e == &scm_nil)
 947     return r;
 948   else if (eq_p (e, make_atom ("EOF")) == &scm_t)
 949     return apply (cdr (assoc (make_atom ("loop2"), a)),
 950                   cons (&scm_unspecified, cons (&scm_t, cons (a, &scm_nil))), a);
 951   else if (eq_p (e, make_atom ("EOF2")) == &scm_t)
 952     return r;
 953   else if (atom_p (e) == &scm_t)
 954     return loop (eval (e, a), readenv (a), a);
 955   else if (eq_p (car (e), make_atom ("define")) == &scm_t)
 956     return loop (&scm_unspecified,
 957                  readenv (a),
 958                  cons (define (e, a), a));
 959   else if (eq_p (car (e), make_atom ("define-macro")) == &scm_t)
 960     return loop (&scm_unspecified,
 961                  readenv (a),
 962                  cons (define_macro (e, a), a));
 963   return loop (eval (e, a), readenv (a), a);
 964 }
 965
 966 int
 967 main (int argc, char *argv[])
 968 {
 969   scm *a = initial_environment ();
 970   display (loop (&scm_unspecified, readenv (a), a));
 971   newline ();
 972   return 0;
 973 }
 974
 975 scm *
 976 apply (scm* fn, scm *x, scm *a)
 977 {
 978 #if DEBUG
 979   printf ("\nc:apply fn=");
 980   display (fn);
 981   printf (" x=");
 982   display (x);
 983   puts ("");
 984 #endif
 985   if (fn == &scm_apply_)
 986     return eval_ (x, a);
 987   return apply_ (fn, x, a);
 988 }
 989
 990 bool evalling_p = false;
 991
 992 scm *
 993 eval (scm *e, scm *a)
 994 {
 995 #if DEBUG
 996   printf ("\nc:eval e=");
 997   display (e);
 998   puts ("");
 999 #endif
1000
1001   scm *eval__ = assoc (make_atom ("eval"), a);
1002   assert (eval__ != &scm_f);
1003   eval__ = cdr (eval__);
1004   if (builtin_p (eval__) == &scm_t
1005       || evalling_p)
1006     return eval_ (e, a);
1007   evalling_p = true;
1008   scm *r = apply (eval__, cons (e, cons (a, &scm_nil)), a);
1009   evalling_p = false;
1010   return r;
1011 }