home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / XLISP / XLISP11.ARK / XLSUBR.C < prev   
Text File  |  1986-10-12  |  12KB  |  538 lines
  1. /* xlsubr - xlisp builtin functions */
  2.  
  3. #ifdef AZTEC
  4. #include "a:stdio.h"
  5. #else
  6. #include <stdio.h>
  7. #endif
  8.  
  9. #include "xlisp.h"
  10.  
  11. /* external variables */
  12. extern int (*xlgetc)();
  13. extern struct node *xlstack;
  14.  
  15. /* local variables */
  16. static char *sgetptr;
  17.  
  18. /* xlsubr - define a builtin function */
  19. xlsubr(sname,subr)
  20.   char *sname; struct node *(*subr)();
  21. {
  22.     struct node *sym;
  23.  
  24.     /* enter the symbol */
  25.     sym = xlenter(sname);
  26.  
  27.     /* initialize the value */
  28.     sym->n_symvalue = newnode(SUBR);
  29.     sym->n_symvalue->n_subr = subr;
  30. }
  31.  
  32. /* xlsvar - define a builtin string variable */
  33. xlsvar(sname,str)
  34.   char *sname,*str;
  35. {
  36.     struct node *sym;
  37.  
  38.     /* enter the symbol */
  39.     sym = xlenter(sname);
  40.  
  41.     /* initialize the value */
  42.     sym->n_symvalue = newnode(STR);
  43.     sym->n_symvalue->n_str = strsave(str);
  44. }
  45.  
  46. /* xlarg - get the next argument */
  47. struct node *xlarg(pargs)
  48.   struct node **pargs;
  49. {
  50.     struct node *arg;
  51.  
  52.     /* make sure the argument exists */
  53.     if (*pargs == NULL)
  54.     xlfail("too few arguments");
  55.  
  56.     /* get the argument value */
  57.     arg = (*pargs)->n_listvalue;
  58.  
  59.     /* move the argument pointer ahead */
  60.     *pargs = (*pargs)->n_listnext;
  61.  
  62.     /* return the argument */
  63.     return (arg);
  64. }
  65.  
  66. /* xlmatch - get an argument and match its type */
  67. struct node *xlmatch(type,pargs)
  68.   int type; struct node **pargs;
  69. {
  70.     struct node *arg;
  71.  
  72.     /* get the argument */
  73.     arg = xlarg(pargs);
  74.  
  75.     /* check its type */
  76.     if (type == LIST) {
  77.     if (arg != NULL && arg->n_type != LIST)
  78.         xlfail("bad argument type");
  79.     }
  80.     else {
  81.     if (arg == NULL || arg->n_type != type)
  82.         xlfail("bad argument type");
  83.     }
  84.  
  85.     /* return the argument */
  86.     return (arg);
  87. }
  88.  
  89. /* xlevarg - get the next argument and evaluate it */
  90. struct node *xlevarg(pargs)
  91.   struct node **pargs;
  92. {
  93.     struct node *oldstk,val;
  94.  
  95.     /* create a new stack frame */
  96.     oldstk = xlsave(&val,NULL);
  97.  
  98.     /* get the argument */
  99.     val.n_ptr = xlarg(pargs);
  100.  
  101.     /* evaluate the argument */
  102.     val.n_ptr = xleval(val.n_ptr);
  103.  
  104.     /* restore the previous stack frame */
  105.     xlstack = oldstk;
  106.  
  107.     /* return the argument */
  108.     return (val.n_ptr);
  109. }
  110.  
  111. /* xlevmatch - get an evaluated argument and match its type */
  112. struct node *xlevmatch(type,pargs)
  113.   int type; struct node **pargs;
  114. {
  115.     struct node *arg;
  116.  
  117.     /* get the argument */
  118.     arg = xlevarg(pargs);
  119.  
  120.     /* check its type */
  121.     if (type == LIST) {
  122.     if (arg != NULL && arg->n_type != LIST)
  123.         xlfail("bad argument type");
  124.     }
  125.     else {
  126.     if (arg == NULL || arg->n_type != type)
  127.         xlfail("bad argument type");
  128.     }
  129.  
  130.     /* return the argument */
  131.     return (arg);
  132. }
  133.  
  134. /* xllastarg - make sure the remainder of the argument list is empty */
  135. xllastarg(args)
  136.   struct node *args;
  137. {
  138.     if (args != NULL)
  139.     xlfail("too many arguments");
  140. }
  141.  
  142. /* assign - assign a value to a symbol */
  143. static assign(sym,val)
  144.   struct node *sym,*val;
  145. {
  146.     struct node *lptr;
  147.  
  148.     /* check for a current object */
  149.     if ((lptr = xlobsym(sym)) != NULL)
  150.     lptr->n_listvalue = val;
  151.     else
  152.     sym->n_symvalue = val;
  153. }
  154.  
  155. /* set - builtin function set */
  156. static struct node *set(args)
  157.   struct node *args;
  158. {
  159.     struct node *oldstk,arg,sym,val;
  160.  
  161.     /* create a new stack frame */
  162.     oldstk = xlsave(&arg,&sym,&val,NULL);
  163.  
  164.     /* initialize */
  165.     arg.n_ptr = args;
  166.  
  167.     /* get the symbol */
  168.     sym.n_ptr = xlevmatch(SYM,&arg.n_ptr);
  169.  
  170.     /* get the new value */
  171.     val.n_ptr = xlevarg(&arg.n_ptr);
  172.  
  173.     /* make sure there aren't any more arguments */
  174.     xllastarg(arg.n_ptr);
  175.  
  176.     /* assign the symbol the value of argument 2 and the return value */
  177.     assign(sym.n_ptr,val.n_ptr);
  178.  
  179.     /* restore the previous stack frame */
  180.     xlstack = oldstk;
  181.  
  182.     /* return the result value */
  183.     return (val.n_ptr);
  184. }
  185.  
  186. /* setq - builtin function setq */
  187. static struct node *setq(args)
  188.   struct node *args;
  189. {
  190.     struct node *oldstk,arg,sym,val;
  191.  
  192.     /* create a new stack frame */
  193.     oldstk = xlsave(&arg,&sym,&val,NULL);
  194.  
  195.     /* initialize */
  196.     arg.n_ptr = args;
  197.  
  198.     /* get the symbol */
  199.     sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
  200.  
  201.     /* get the new value */
  202.     val.n_ptr = xlevarg(&arg.n_ptr);
  203.  
  204.     /* make sure there aren't any more arguments */
  205.     xllastarg(arg.n_ptr);
  206.  
  207.     /* assign the symbol the value of argument 2 and the return value */
  208.     assign(sym.n_ptr,val.n_ptr);
  209.  
  210.     /* restore the previous stack frame */
  211.     xlstack = oldstk;
  212.  
  213.     /* return the result value */
  214.     return (val.n_ptr);
  215. }
  216.  
  217. /* load - direct input from a file */
  218. static struct node *load(args)
  219.   struct node *args;
  220. {
  221.     struct node *fname;
  222.  
  223.     /* get the file name */
  224.     fname = xlevmatch(STR,&args);
  225.  
  226.     /* make sure there aren't any more arguments */
  227.     xllastarg(args);
  228.  
  229.     /* direct input from the file */
  230.     xlfin(fname->n_str);
  231.  
  232.     /* return the filename */
  233.     return (fname);
  234. }
  235.  
  236. /* defun - builtin function defun */
  237. static struct node *defun(args)
  238.   struct node *args;
  239. {
  240.     struct node *oldstk,arg,sym,fargs,fun;
  241.  
  242.     /* create a new stack frame */
  243.     oldstk = xlsave(&arg,&sym,&fargs,&fun,NULL);
  244.  
  245.     /* initialize */
  246.     arg.n_ptr = args;
  247.  
  248.     /* get the function symbol */
  249.     sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
  250.  
  251.     /* get the formal argument list */
  252.     fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
  253.  
  254.     /* create a new function definition */
  255.     fun.n_ptr = newnode(LIST);
  256.     fun.n_ptr->n_listvalue = fargs.n_ptr;
  257.     fun.n_ptr->n_listnext = arg.n_ptr;
  258.  
  259.     /* make the symbol point to a new function definition */
  260.     assign(sym.n_ptr,fun.n_ptr);
  261.  
  262.     /* restore the previous stack frame */
  263.     xlstack = oldstk;
  264.  
  265.     /* return the function symbol */
  266.     return (sym.n_ptr);
  267. }
  268.  
  269. /* sgetc - get a character from a string */
  270. static int sgetc()
  271. {
  272.     if (*sgetptr == 0)
  273.     return (-1);
  274.     else
  275.     return (*sgetptr++);
  276. }
  277.  
  278. /* read - read an expression */
  279. static struct node *read(args)
  280.   struct node *args;
  281. {
  282.     struct node *val;
  283.     int (*oldgetc)();
  284.  
  285.     /* save the old input stream */
  286.     oldgetc = xlgetc;
  287.  
  288.     /* get the string or file pointer */
  289.     if (args != NULL) {
  290.     sgetptr = xlevmatch(STR,&args)->n_str;
  291.     xlgetc = sgetc;
  292.     }
  293.  
  294.     /* make sure there aren't any more arguments */
  295.     xllastarg(args);
  296.  
  297.     /* read an expression */
  298.     val = xlread();
  299.  
  300.     /* restore the old input stream */
  301.     xlgetc = oldgetc;
  302.  
  303.     /* return the expression read */
  304.     return (val);
  305. }
  306.  
  307. /* fwhile - builtin function while */
  308. static struct node *fwhile(args)
  309.   struct node *args;
  310. {
  311.     struct node *oldstk,farg,arg,*val;
  312.  
  313.     /* create a new stack frame */
  314.     oldstk = xlsave(&farg,&arg,NULL);
  315.  
  316.     /* initialize */
  317.     farg.n_ptr = arg.n_ptr = args;
  318.  
  319.     /* loop until test fails */
  320.     val = NULL;
  321.     for (; TRUE; arg.n_ptr = farg.n_ptr) {
  322.  
  323.     /* evaluate the test expression */
  324.     if (!testvalue(xlevarg(&arg.n_ptr)))
  325.         break;
  326.  
  327.     /* evaluate each remaining argument */
  328.     while (arg.n_ptr != NULL)
  329.         val = xlevarg(&arg.n_ptr);
  330.     }
  331.  
  332.     /* restore the previous stack frame */
  333.     xlstack = oldstk;
  334.  
  335.     /* return the last test expression value */
  336.     return (val);
  337. }
  338.  
  339. /* frepeat - builtin function repeat */
  340. static struct node *frepeat(args)
  341.   struct node *args;
  342. {
  343.     struct node *oldstk,farg,arg,*val;
  344.     int cnt;
  345.  
  346.     /* create a new stack frame */
  347.     oldstk = xlsave(&farg,&arg,NULL);
  348.  
  349.     /* initialize */
  350.     arg.n_ptr = args;
  351.  
  352.     /* evaluate the repeat count */
  353.     cnt = xlevmatch(INT,&arg.n_ptr)->n_int;
  354.  
  355.     /* save the first expression to repeat */
  356.     farg.n_ptr = arg.n_ptr;
  357.  
  358.     /* loop until test fails */
  359.     val = NULL;
  360.     for (; cnt > 0; cnt--) {
  361.  
  362.     /* evaluate each remaining argument */
  363.     while (arg.n_ptr != NULL)
  364.         val = xlevarg(&arg.n_ptr);
  365.  
  366.     /* restore pointer to first expression */
  367.     arg.n_ptr = farg.n_ptr;
  368.     }
  369.  
  370.     /* restore the previous stack frame */
  371.     xlstack = oldstk;
  372.  
  373.     /* return the last test expression value */
  374.     return (val);
  375. }
  376.  
  377. /* foreach - builtin function foreach */
  378. static struct node *foreach(args)
  379.   struct node *args;
  380. {
  381.     struct node *oldstk,arg,sym,list,code,oldbnd,*val;
  382.  
  383.     /* create a new stack frame */
  384.     oldstk = xlsave(&arg,&sym,&list,&code,&oldbnd,NULL);
  385.  
  386.     /* initialize */
  387.     arg.n_ptr = args;
  388.  
  389.     /* get the symbol to bind to each list element */
  390.     sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
  391.  
  392.     /* save the old binding of the symbol */
  393.     oldbnd.n_ptr = sym.n_ptr->n_symvalue;
  394.  
  395.     /* get the list to iterate over */
  396.     list.n_ptr = xlevmatch(LIST,&arg.n_ptr);
  397.  
  398.     /* save the pointer to the code */
  399.     code.n_ptr = arg.n_ptr;
  400.  
  401.     /* loop until test fails */
  402.     val = NULL;
  403.     while (list.n_ptr != NULL) {
  404.  
  405.     /* check the node type */
  406.     if (list.n_ptr->n_type != LIST)
  407.         xlfail("bad node type in list");
  408.  
  409.     /* bind the symbol to the list element */
  410.     sym.n_ptr->n_symvalue = list.n_ptr->n_listvalue;
  411.  
  412.     /* evaluate each remaining argument */
  413.     while (arg.n_ptr != NULL)
  414.         val = xlevarg(&arg.n_ptr);
  415.  
  416.     /* point to the next list element */
  417.     list.n_ptr = list.n_ptr->n_listnext;
  418.  
  419.     /* restore the pointer to the code */
  420.     arg.n_ptr = code.n_ptr;
  421.     }
  422.  
  423.     /* restore the previous stack frame */
  424.     xlstack = oldstk;
  425.  
  426.     /* restore the old binding of the symbol */
  427.     sym.n_ptr->n_symvalue = oldbnd.n_ptr;
  428.  
  429.     /* return the last test expression value */
  430.     return (val);
  431. }
  432.  
  433. /* fif - builtin function if */
  434. static struct node *fif(args)
  435.   struct node *args;
  436. {
  437.     struct node *oldstk,arg,testexpr,thenexpr,elseexpr,*val;
  438.     int dothen;
  439.  
  440.     /* create a new stack frame */
  441.     oldstk = xlsave(&arg,&testexpr,&thenexpr,&elseexpr,NULL);
  442.  
  443.     /* initialize */
  444.     arg.n_ptr = args;
  445.  
  446.     /* evaluate the test expression */
  447.     testexpr.n_ptr = xlevarg(&arg.n_ptr);
  448.  
  449.     /* get the then clause */
  450.     thenexpr.n_ptr = xlmatch(LIST,&arg.n_ptr);
  451.  
  452.     /* get the else clause */
  453.     if (arg.n_ptr != NULL)
  454.     elseexpr.n_ptr = xlmatch(LIST,&arg.n_ptr);
  455.     else
  456.     elseexpr.n_ptr = NULL;
  457.  
  458.     /* make sure there aren't any more arguments */
  459.     xllastarg(arg.n_ptr);
  460.  
  461.     /* figure out which expression to evaluate */
  462.     dothen = testvalue(testexpr.n_ptr);
  463.  
  464.     /* default the result value to the value of the test expression */
  465.     val = testexpr.n_ptr;
  466.  
  467.     /* evaluate the appropriate clause */
  468.     if (dothen)
  469.     while (thenexpr.n_ptr != NULL)
  470.         val = xlevarg(&thenexpr.n_ptr);
  471.     else
  472.     while (elseexpr.n_ptr != NULL)
  473.         val = xlevarg(&elseexpr.n_ptr);
  474.  
  475.     /* restore the previous stack frame */
  476.     xlstack = oldstk;
  477.  
  478.     /* return the last value */
  479.     return (val);
  480. }
  481.  
  482. /* quote - builtin function to quote an expression */
  483. static struct node *quote(args)
  484.   struct node *args;
  485. {
  486.     /* make sure there is exactly one argument */
  487.     if (args == NULL || args->n_listnext != NULL)
  488.     xlfail("incorrect number of arguments");
  489.  
  490.     /* return the quoted expression */
  491.     return (args->n_listvalue);
  492. }
  493.  
  494. /* fexit - get out of xlisp */
  495. fexit()
  496. {
  497.     exit();
  498. }
  499.  
  500. /* testvalue - test a value for true or false */
  501. static int testvalue(val)
  502.   struct node *val;
  503. {
  504.     /* check for a nil value */
  505.     if (val == NULL)
  506.     return (FALSE);
  507.  
  508.     /* check the value type */
  509.     switch (val->n_type) {
  510.     case INT:
  511.         return (val->n_int != 0);
  512.     case STR:
  513.         return (strlen(val->n_str) != 0);
  514.     default:
  515.         return (TRUE);
  516.     }
  517. }
  518.  
  519. /* xlinit - xlisp initialization routine */
  520. xlinit()
  521. {
  522.     /* enter a copyright notice into the oblist */
  523.     xlenter("Copyright-1983-by-David-Betz");
  524.  
  525.     /* enter the builtin functions */
  526.     xlsubr("set",set);
  527.     xlsubr("setq",setq);
  528.     xlsubr("load",load);
  529.     xlsubr("read",read);
  530.     xlsubr("quote",quote);
  531.     xlsubr("while",fwhile);
  532.     xlsubr("repeat",frepeat);
  533.     xlsubr("foreach",foreach);
  534.     xlsubr("defun",defun);
  535.     xlsubr("if",fif);
  536.     xlsubr("exit",fexit);
  537. }
  538.