home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / languages / scheme / soid2_4 / siod-v2_4 / c / siod next >
Encoding:
Text File  |  1992-06-23  |  4.3 KB  |  210 lines
  1. /* Scheme In One Defun, but in C this time.
  2.  
  3.  *                        COPYRIGHT (c) 1989 BY                             *
  4.  *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  5.  *        See the source file SLIB.C for more information.                  *
  6.  
  7. */
  8.  
  9. /*
  10.  
  11. gjc@paradigm.com
  12.  
  13. Paradigm Associates Inc          Phone: 617-492-6079
  14. 29 Putnam Ave, Suite 6
  15. Cambridge, MA 02138
  16.  
  17.   */
  18.  
  19. #include <stdio.h>
  20.  
  21. #include "siod.h"
  22.  
  23. /* This illustrates calling the main program entry points and enabling our
  24.    own example subrs */
  25.  
  26. LISP our_gc_mark();
  27. void our_gc_free();
  28. void our_print();
  29. LISP our_readm();
  30. LISP our_eval();
  31.  
  32. main(argc,argv)
  33.  int argc; char **argv;
  34. {long gc_kind;
  35.  print_welcome();
  36.  process_cla(argc,argv,1);
  37.  set_gc_hooks(NULL,NULL,NULL,NULL,&gc_kind);
  38.  print_hs_1();
  39.  init_storage();
  40.  init_subrs();
  41.  if (gc_kind == 0)
  42.    {set_gc_hooks(NULL,NULL,our_gc_mark,our_gc_free,&gc_kind);
  43.     set_read_hooks("\"","\"",our_readm,NULL);
  44.     set_eval_hooks(our_eval);
  45.     set_print_hooks(our_print);}
  46.  our_subrs((gc_kind == 0) ? 1 : 0);
  47.  repl_driver(1,1);
  48.  printf("EXIT\n");}
  49.  
  50. /* This is cfib, for compiled fib. Test to see what the overhead
  51.    of interpretation actually is in a given implementation 
  52.  */
  53.  
  54. LISP my_one;
  55. LISP my_two;
  56.  
  57. /*   (define (standard-fib x)
  58.        (if (< x 2)
  59.          x
  60.          (+ (standard-fib (- x 1))
  61.         (standard-fib (- x 2)))))  
  62. */
  63.  
  64. LISP cfib(x)
  65.      LISP x;
  66. {if NNULLP(lessp(x,my_two))
  67.    return(x);
  68.  else
  69.    return(plus(cfib(difference(x,my_one)),
  70.            cfib(difference(x,my_two))));}
  71.  
  72.  
  73. #ifdef vms
  74. #include <descrip.h>
  75. #include <ssdef.h>
  76. LISP sys_edit(fname)
  77.  LISP fname;
  78. {struct dsc$descriptor_s d;
  79.  long iflag;
  80.  if NTYPEP(fname,tc_symbol) err("filename not a symbol",fname);
  81.  d.dsc$b_dtype = DSC$K_DTYPE_T;
  82.  d.dsc$b_class = DSC$K_CLASS_S;
  83.  d.dsc$w_length = strlen(PNAME(fname));
  84.  d.dsc$a_pointer = PNAME(fname);
  85.  iflag = no_interrupt(1);
  86.  edt$edit(&d);
  87.  no_interrupt(iflag);
  88.  return(fname);}
  89.  
  90. LISP vms_debug(v)
  91.      LISP v;
  92. {lib$signal(SS$_DEBUG);
  93.  return(v);}
  94.  
  95. #endif
  96.  
  97. LISP our_gc_mark(ptr)
  98.      LISP ptr;
  99. {return(NIL);}
  100.  
  101. void our_gc_free(ptr)
  102.      LISP ptr;
  103. {free(PNAME(ptr));
  104.  PNAME(ptr) = 0;}
  105.  
  106. void our_print(ptr,f)
  107.      LISP ptr;
  108.      FILE *f;
  109. {fput_st(f,"\"");
  110.  fput_st(f,PNAME(ptr));
  111.  fput_st(f,"\"");}
  112.  
  113. #define tc_string tc_user_1
  114.  
  115. LISP strcons(length)
  116.      long length;
  117. {long flag;
  118.  LISP s;
  119.  s = symcons("",NIL);
  120.  flag = no_interrupt(1);
  121.  PNAME(s) = must_malloc(length);
  122.  no_interrupt(flag);
  123.  (*s).type = tc_string;
  124.  return(s);}
  125.  
  126. LISP string_append(args)
  127.      LISP args;
  128. {long size;
  129.  LISP l,s;
  130.  char *data;
  131.  size = 0;
  132.  for(l=args;NNULLP(l);l=cdr(l))
  133.    {s = car(l);
  134.     if (NTYPEP(s,tc_symbol) && NTYPEP(s,tc_string))
  135.       err("wta to string-append",s);
  136.     size = size + strlen(PNAME(s));}
  137.  s = strcons(size+1);
  138.  data = PNAME(s);
  139.  data[0] = 0;
  140.  for(l=args;NNULLP(l);l=cdr(l))
  141.    strcat(data,PNAME(car(l)));
  142.  return(s);}
  143.  
  144. LISP our_readm(tc,f)
  145.      int tc;
  146.      struct gen_readio *f;
  147. {char temp[100];
  148.  int c;
  149.  long j;
  150.  LISP s;
  151.  j = 0;
  152.  while(((c = GETC_FCN(f)) != tc) && (c != EOF))
  153.    {if ((j + 2) > sizeof(temp)) err("read string overflow",NIL);
  154.     temp[j] = c;
  155.     ++j;}
  156.  s = strcons(j+1);
  157.  temp[j] = 0;
  158.  strcpy(PNAME(s),temp);
  159.  return(s);}
  160.  
  161. LISP our_eval(obj,formp,envp)
  162.      LISP obj,*formp,*envp;
  163. {LISP ind;
  164.  char buff[2];
  165.  long n,j;
  166.  if NTYPEP(obj,tc_string) err("eval bug",obj);
  167.  n = strlen(PNAME(obj));
  168.  ind = leval(car(cdr(*formp)),*envp);
  169.  if NFLONUMP(ind) err("non numeric string index",ind);
  170.  j = (long) FLONM(ind);
  171.  if ((j < 0) || (j >= n)) err("string index out of range",ind);
  172.  buff[0] = PNAME(obj)[j];
  173.  buff[1] = 0;
  174.  *formp = rintern(buff);
  175.  return(NIL);}
  176.  
  177. int rfs_getc(p)
  178.      unsigned char **p;
  179. {int i;
  180.  i = **p;
  181.  if (!i) return(EOF);
  182.  *p = *p + 1;
  183.  return(i);}
  184.  
  185. void rfs_putc(c,p)
  186.      unsigned char c,**p;
  187. {*p = *p - 1;}
  188.  
  189. LISP read_from_string(x)
  190.      LISP x;
  191. {char *p;
  192.  if NTYPEP(x,tc_string) err("not a string",x);
  193.  p = PNAME(x);
  194.  return(gen_read(rfs_getc,rfs_putc,&p));}
  195.  
  196. our_subrs(flag)
  197.      int flag;
  198. {my_one = flocons((double) 1.0);
  199.  my_two = flocons((double) 2.0);
  200.  gc_protect(&my_one);
  201.  gc_protect(&my_two);
  202.  init_subr("cfib",tc_subr_1,cfib);
  203. #ifdef vms
  204.  init_subr("edit",tc_subr_1,sys_edit);
  205.  init_subr("vms-debug",tc_subr_1,vms_debug);
  206. #endif
  207.  if (flag)
  208.    {init_subr("string-append",tc_lsubr,string_append);
  209.     init_subr("read-from-string",tc_subr_1,read_from_string);}}
  210.