home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / siod / siod_v28.lha / siod.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-08-16  |  1.8 KB  |  95 lines
  1. /* Scheme In One Defun, but in C this time.
  2.  
  3.  *                    COPYRIGHT (c) 1988-1992 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. An example main-program call with some customized subrs.
  18.  
  19.   */
  20.  
  21. #include <stdio.h>
  22. #ifdef THINK_C
  23. #include <console.h>
  24. #endif
  25.  
  26. #include "siod.h"
  27.  
  28. LISP my_one;
  29. LISP my_two;
  30.  
  31. LISP cfib(LISP x);
  32.  
  33. #ifdef VMS
  34. LISP vms_debug(LISP cmd);
  35. #endif
  36.  
  37. int main(int argc,char **argv)
  38. {print_welcome();
  39. #ifdef THINK_C
  40.  argc = ccommand(&argv);
  41. #endif
  42.  process_cla(argc,argv,1);
  43.  print_hs_1();
  44.  init_storage();
  45.  init_subrs();
  46.  my_one = flocons((double) 1.0);
  47.  my_two = flocons((double) 2.0);
  48.  gc_protect(&my_one);
  49.  gc_protect(&my_two);
  50.  init_subr("cfib",tc_subr_1,cfib);
  51. #ifdef VMS
  52.  init_subr("vms-debug",tc_subr_1,vms_debug);
  53. #endif
  54.  repl_driver(1,1);
  55.  printf("EXIT\n");}
  56.  
  57. /* This is cfib, (compiled fib). Test to see what the overhead
  58.    of interpretation actually is in a given implementation benchmark
  59.    standard-fib against cfib.
  60.  
  61.    (define (standard-fib x)
  62.      (if (< x 2)
  63.          x
  64.          (+ (standard-fib (- x 1))
  65.         (standard-fib (- x 2)))))  
  66.  
  67. */
  68.  
  69. LISP cfib(LISP x)
  70. {if NNULLP(lessp(x,my_two))
  71.    return(x);
  72.  else
  73.    return(plus(cfib(difference(x,my_one)),
  74.            cfib(difference(x,my_two))));}
  75.  
  76. #ifdef VMS
  77.  
  78. #include <ssdef.h>
  79. #include <descrip.h>
  80.  
  81. LISP vms_debug(arg)
  82.      LISP arg;
  83. {unsigned char arg1[257];
  84.  char *data;
  85.  if NULLP(arg)
  86.    lib$signal(SS$_DEBUG,0);
  87.  else
  88.    {data = get_c_string(arg);
  89.     arg1[0] = strlen(data);
  90.     memcpy(&arg1[1],data,arg1[0]);
  91.     lib$signal(SS$_DEBUG,1,arg1);}
  92.  return(NIL);}
  93.  
  94. #endif
  95.