home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / languages / siod_v2 / c / slib < prev   
Text File  |  1992-06-23  |  39KB  |  1,622 lines
  1. /* Scheme In One Defun, but in C this time.
  2.  
  3.  *                        COPYRIGHT (c) 1989 BY                             *
  4.  *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  5.  *               ALL RIGHTS RESERVED                              *
  6.  
  7. Permission to use, copy, modify, distribute and sell this software
  8. and its documentation for any purpose and without fee is hereby
  9. granted, provided that the above copyright notice appear in all copies
  10. and that both that copyright notice and this permission notice appear
  11. in supporting documentation, and that the name of Paradigm Associates
  12. Inc not be used in advertising or publicity pertaining to distribution
  13. of the software without specific, written prior permission.
  14.  
  15. PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  16. ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  17. PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  18. ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
  19. WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
  20. ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  21. SOFTWARE.
  22.  
  23. */
  24.  
  25. /*
  26.  
  27. gjc@paradigm.com
  28.  
  29. Paradigm Associates Inc          Phone: 617-492-6079
  30. 29 Putnam Ave, Suite 6
  31. Cambridge, MA 02138
  32.  
  33.  
  34.    Release 1.0: 24-APR-88
  35.    Release 1.1: 25-APR-88, added: macros, predicates, load. With additions by
  36.     Barak.Pearlmutter@DOGHEN.BOLTZ.CS.CMU.EDU: Full flonum recognizer,
  37.     cleaned up uses of NULL/0. Now distributed with siod.scm.
  38.    Release 1.2: 28-APR-88, name changes as requested by JAR@AI.AI.MIT.EDU,
  39.     plus some bug fixes.
  40.    Release 1.3: 1-MAY-88, changed env to use frames instead of alist.
  41.     define now works properly. vms specific function edit.
  42.    Release 1.4 20-NOV-89. Minor Cleanup and remodularization.
  43.     Now in 3 files, siod.h, slib.c, siod.c. Makes it easier to write your
  44.     own main loops. Some short-int changes for lightspeed C included.
  45.    Release 1.5 29-NOV-89. Added startup flag -g, select stop and copy
  46.     or mark-and-sweep garbage collection, which assumes that the stack/register
  47.     marking code is correct for your architecture. 
  48.    Release 2.0 1-DEC-89. Added repl_hooks, Catch, Throw. This is significantly
  49.     different enough (from 1.3) now that I'm calling it a major release.
  50.    Release 2.1 4-DEC-89. Small reader features, dot, backquote, comma.
  51.    Release 2.2 5-DEC-89. gc,read,print,eval, hooks for user defined datatypes.
  52.    Release 2.3 6-DEC-89. save_forms, obarray intern mechanism. comment char.
  53.    Release 2.3a......... minor speed-ups. i/o interrupt considerations.
  54.    Release 2.4 27-APR-90 gen_readr, for read-from-string.
  55.  
  56.   */
  57.  
  58. #include <stdio.h>
  59. #include <string.h>
  60. #include <ctype.h>
  61. #include <setjmp.h>
  62. #include <signal.h>
  63. #include <math.h>
  64. #ifdef vms
  65. #include <stdlib.h>
  66. #endif
  67.  
  68. #ifdef ARM
  69. #include <stdlib.h>
  70. #endif
  71.  
  72.  
  73.  
  74.  
  75. #include "siod.h"
  76.  
  77. LISP heap_1,heap_2;
  78. LISP heap,heap_end,heap_org;
  79.  
  80. long heap_size = 5000;
  81. long old_heap_used;
  82. long which_heap;
  83. long gc_status_flag = 1;
  84. char *init_file = (char *) NULL;
  85. char tkbuffer[TKBUFFERN];
  86.  
  87. long gc_kind_copying = 1;
  88.  
  89. long gc_cells_allocated = 0;
  90. double gc_time_taken;
  91. LISP *stack_start_ptr;
  92. LISP freelist;
  93.  
  94. jmp_buf errjmp;
  95. long errjmp_ok = 0;
  96. long nointerrupt = 1;
  97. long interrupt_differed = 0;
  98.  
  99. LISP oblistvar = NIL;
  100. LISP truth = NIL;
  101. LISP eof_val = NIL;
  102. LISP sym_errobj = NIL;
  103. LISP sym_progn = NIL;
  104. LISP sym_lambda = NIL;
  105. LISP sym_quote = NIL;
  106. LISP sym_dot = NIL;
  107. LISP open_files = NIL;
  108. LISP unbound_marker = NIL;
  109.  
  110. LISP *obarray;
  111. long obarray_dim = 100;
  112.  
  113. struct catch_frame
  114. {LISP tag;
  115.  LISP retval;
  116.  jmp_buf cframe;
  117.  struct catch_frame *next;};
  118.  
  119. struct gc_protected
  120. {LISP *location;
  121.  long length;
  122.  struct gc_protected *next;};
  123.  
  124. struct catch_frame *catch_framep = (struct catch_frame *) NULL;
  125.  
  126.  
  127. process_cla(argc,argv,warnflag)
  128.  int argc,warnflag; char **argv;
  129. {int k;
  130.  for(k=1;k<argc;++k)
  131.    {if (strlen(argv[k])<2) continue;
  132.     if (argv[k][0] != '-')
  133.       {if (warnflag) printf("bad arg: %s\n",argv[k]);continue;}
  134.     switch(argv[k][1])
  135.       {case 'h':
  136.      heap_size = atol(&(argv[k][2])); break;
  137.        case 'o':
  138.      obarray_dim = atol(&(argv[k][2])); break;
  139.        case 'i':
  140.      init_file = &(argv[k][2]); break;
  141.        case 'g':
  142.      gc_kind_copying = atol(&(argv[k][2])); break;
  143.        default: if (warnflag) printf("bad arg: %s\n",argv[k]);}}}
  144.  
  145. print_welcome()
  146. {printf("Welcome to SIOD, Scheme In One Defun, Version 2.4\n");
  147.  printf("(C) Copyright 1988, 1989, 1990 Paradigm Associates Inc.\n");}
  148.  
  149. print_hs_1()
  150. {printf("heap_size = %ld cells, %ld bytes. GC is %s\n",
  151.         heap_size,heap_size*sizeof(struct obj),
  152.     (gc_kind_copying == 1) ? "stop and copy" : "mark and sweep");}
  153.  
  154. print_hs_2()
  155. {if (gc_kind_copying == 1)
  156.    printf("heap_1 at 0x%lX, heap_2 at 0x%lX\n",heap_1,heap_2);
  157.  else
  158.    printf("heap_1 at 0x%lX\n",heap_1);}
  159.  
  160. long no_interrupt(n)
  161.      long n;
  162. {long x;
  163.  x = nointerrupt;
  164.  nointerrupt = n;
  165.  if ((nointerrupt == 0) && (interrupt_differed == 1))
  166.    {interrupt_differed = 0;
  167.     err_ctrl_c();}
  168.  return(x);}
  169.  
  170.  
  171.  
  172. void handle_sigfpe(sig,code,scp)
  173.  long sig,code; struct sigcontext *scp;
  174. {signal(SIGFPE,handle_sigfpe);
  175.  err("floating point exception",NIL);}
  176.  
  177. void handle_sigint(sig,code,scp)
  178.  long sig,code; struct sigcontext *scp;
  179. {signal(SIGINT,handle_sigint);
  180.  if (nointerrupt == 1)
  181.    interrupt_differed = 1;
  182.  else
  183.    err_ctrl_c();}
  184.  
  185. err_ctrl_c()
  186. {err("control-c interrupt",NIL);}
  187.  
  188. LISP get_eof_val()
  189. {return(eof_val);}
  190.  
  191. repl_driver(want_sigint,want_init)
  192.      long want_sigint,want_init;
  193. {int k;
  194.  LISP stack_start;
  195.  stack_start_ptr = &stack_start;
  196.  k = setjmp(errjmp);
  197.  if (k == 2) return;
  198.  if (want_sigint) signal(SIGFPE,handle_sigfpe);
  199.  signal(SIGINT,handle_sigint);
  200.  close_open_files();
  201.  catch_framep = (struct catch_frame *) NULL;
  202.  errjmp_ok = 1;
  203.  interrupt_differed = 0;
  204.  nointerrupt = 0;
  205.  if (want_init && init_file && (k == 0)) vload(init_file,0);
  206.  repl();}
  207.  
  208. #ifdef unix
  209. #include <sys/types.h>
  210. #include <sys/times.h>
  211. struct tms time_buffer;
  212. double myruntime()
  213. {times(&time_buffer);
  214.  return(time_buffer.tms_utime/60.0);}
  215. #else
  216. #ifdef vms
  217. #include <time.h>
  218. double myruntime()
  219. {return(clock() * 1.0e-2);}
  220. #else
  221. #ifdef ARM
  222. /* this is still wrong */
  223. #include <time.h>
  224. double myruntime()
  225. {clock_t x;
  226.  x = clock();
  227.  return(((double) x)/((double) CLOCKS_PER_SEC));}
  228. #else
  229. double myruntime()
  230. {long x;
  231.  long time();
  232.  time(&x);
  233.  return((double) x);}
  234. #endif
  235. #endif
  236. #endif
  237.  
  238.  
  239. void (*repl_puts)() = NULL;
  240. LISP (*repl_read)() = NULL;
  241. LISP (*repl_eval)() = NULL;
  242. void (*repl_print)() = NULL;
  243.  
  244. void set_repl_hooks(puts_f,read_f,eval_f,print_f)
  245.      void (*puts_f)();
  246.      LISP (*read_f)();
  247.      LISP (*eval_f)();
  248.      void (*print_f)();
  249. {repl_puts = puts_f;
  250.  repl_read = read_f;
  251.  repl_eval = eval_f;
  252.  repl_print = print_f;}
  253.  
  254. fput_st(f,st)
  255.      FILE *f;
  256.      char *st;
  257. {long flag;
  258.  flag = no_interrupt(1);
  259.  fprintf(f,"%s",st);
  260.  no_interrupt(flag);}
  261.  
  262. put_st(st)
  263.      char *st;
  264. {fput_st(stdout,st);}
  265.      
  266. grepl_puts(st)
  267.      char *st;
  268. {if (repl_puts == NULL)
  269.    put_st(st);
  270.  else
  271.    (*repl_puts)(st);}
  272.      
  273. repl() 
  274. {LISP x,cw;
  275.  double rt;
  276.  while(1)
  277.    {if ((gc_kind_copying == 1) && ((gc_status_flag) || heap >= heap_end))
  278.      {rt = myruntime();
  279.       gc_stop_and_copy();
  280.       sprintf(tkbuffer,
  281.           "GC took %g seconds, %ld compressed to %ld, %ld free\n",
  282.           myruntime()-rt,old_heap_used,heap-heap_org,heap_end-heap);
  283.       grepl_puts(tkbuffer);}
  284.     grepl_puts("> ");
  285.     if (repl_read == NULL) x = lread();
  286.     else x = (*repl_read)();
  287.     if EQ(x,eof_val) break;
  288.     rt = myruntime();
  289.     if (gc_kind_copying == 1)
  290.       cw = heap;
  291.     else
  292.       {gc_cells_allocated = 0;
  293.        gc_time_taken = 0.0;}
  294.     if (repl_eval == NULL) x = leval(x,NIL);
  295.     else x = (*repl_eval)();
  296.     if (gc_kind_copying == 1)
  297.       sprintf(tkbuffer,
  298.           "Evaluation took %g seconds %ld cons work\n",
  299.           myruntime()-rt,
  300.           heap-cw);
  301.     else
  302.       sprintf(tkbuffer,
  303.           "Evaluation took %g seconds (%g in gc) %ld cons work\n",
  304.           myruntime()-rt,
  305.           gc_time_taken,
  306.           gc_cells_allocated);
  307.     grepl_puts(tkbuffer);
  308.     if (repl_print == NULL) lprint(x);
  309.     else (*repl_print)(x);}}
  310.  
  311. err(message,x)
  312.  char *message; LISP x;
  313. {nointerrupt = 1;
  314.  if NNULLP(x) 
  315.     print