/* xllist - xlisp list builtin functions */ #ifdef AZTEC #include "stdio.h" #else #include #endif #include "xlisp.h" /* external variables */ extern struct node *xlstack; extern struct node *s_unbound; extern struct node *true; /* forward declarations */ FORWARD struct node *nth(),*member(),*assoc(),*afind(); FORWARD struct node *delete(),*subst(),*sublis(),*map(); FORWARD int eq(),equal(); /* xcar - return the car of a list */ struct node *xcar(args) struct node *args; { struct node *list; /* get the list and return its car */ list = xlmatch(LIST,&args); xllastarg(args); return (list ? list->n_listvalue : NULL); } /* xcaar - return the caar of a list */ struct node *xcaar(args) struct node *args; { struct node *list; /* get the list and return its caar */ list = xlmatch(LIST,&args); xllastarg(args); if (list) list = list->n_listvalue; return (list ? list->n_listvalue : NULL); } /* xcadr - return the cadr of a list */ struct node *xcadr(args) struct node *args; { struct node *list; /* get the list and return its cadr */ list = xlmatch(LIST,&args); xllastarg(args); if (list) list = list->n_listnext; return (list ? list->n_listvalue : NULL); } /* xcdr - return the cdr of a list */ struct node *xcdr(args) struct node *args; { struct node *list; /* get the list and return its cdr */ list = xlmatch(LIST,&args); xllastarg(args); return (list ? list->n_listnext : NULL); } /* xcdar - return the cdar of a list */ struct node *xcdar(args) struct node *args; { struct node *list; /* get the list and return its cdar */ list = xlmatch(LIST,&args); xllastarg(args); if (list) list = list->n_listvalue; return (list ? list->n_listnext : NULL); } /* xcddr - return the cddr of a list */ struct node *xcddr(args) struct node *args; { struct node *list; /* get the list and return its cddr */ list = xlmatch(LIST,&args); xllastarg(args); if (list) list = list->n_listnext; return (list ? list->n_listnext : NULL); } /* xcons - construct a new list cell */ struct node *xcons(args) struct node *args; { struct node *arg1,*arg2,*val; /* get the two arguments */ arg1 = xlarg(&args); arg2 = xlarg(&args); xllastarg(args); /* construct a new list element */ val = newnode(LIST); val->n_listvalue = arg1; val->n_listnext = arg2; /* return the list */ return (val); } /* xlist - built a list of the arguments */ struct node *xlist(args) struct node *args; { struct node *oldstk,arg,list,val,*last,*lptr; /* create a new stack frame */ oldstk = xlsave(&arg,&list,&val,NULL); /* initialize */ arg.n_ptr = args; /* evaluate and append each argument */ for (last = NULL; arg.n_ptr != NULL; last = lptr) { /* evaluate the next argument */ val.n_ptr = xlarg(&arg.n_ptr); /* append this argument to the end of the list */ lptr = newnode(LIST); if (last == NULL) list.n_ptr = lptr; else last->n_listnext = lptr; lptr->n_listvalue = val.n_ptr; } /* restore the previous stack frame */ xlstack = oldstk; /* return the list */ return (list.n_ptr); } /* xappend - builtin function append */ struct node *xappend(args) struct node *args; { struct node *oldstk,arg,list,last,val,*lptr; /* create a new stack frame */ oldstk = xlsave(&arg,&list,&last,&val,NULL); /* initialize */ arg.n_ptr = args; /* evaluate and append each argument */ while (arg.n_ptr != NULL) { /* evaluate the next argument */ list.n_ptr = xlmatch(LIST,&arg.n_ptr); /* append each element of this list to the result list */ while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) { /* append this element */ lptr = newnode(LIST); if (last.n_ptr == NULL) val.n_ptr = lptr; else last.n_ptr->n_listnext = lptr; lptr->n_listvalue = list.n_ptr->n_listvalue; /* save the new last element */ last.n_ptr = lptr; /* move to the next element */ list.n_ptr = list.n_ptr->n_listnext; } /* make sure the list ended in a nil */ if (list.n_ptr != NULL) xlfail("bad list"); } /* restore previous stack frame */ xlstack = oldstk; /* return the list */ return (val.n_ptr); } /* xreverse - builtin function reverse */ struct node *xreverse(args) struct node *args; { struct node *oldstk,list,val,*lptr; /* create a new stack frame */ oldstk = xlsave(&list,&val,NULL); /* get the list to reverse */ list.n_ptr = xlmatch(LIST,&args); xllastarg(args); /* append each element of this list to the result list */ while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) { /* append this element */ lptr = newnode(LIST); lptr->n_listvalue = list.n_ptr->n_listvalue; lptr->n_listnext = val.n_ptr; val.n_ptr = lptr; /* move to the next element */ list.n_ptr = list.n_ptr->n_listnext; } /* make sure the list ended in a nil */ if (list.n_ptr != NULL) xlfail("bad list"); /* restore previous stack frame */ xlstack = oldstk; /* return the list */ return (val.n_ptr); } /* xlast - return the last cons of a list */ struct node *xlast(args) struct node *args; { struct node *list; /* get the list */ list = xlmatch(LIST,&args); xllastarg(args); /* find the last cons */ while (list && list->n_type == LIST && list->n_listnext) list = list->n_listnext; /* make sure the list ended correctly */ if (list == NULL && list->n_type != LIST) xlfail("bad list"); /* return the last element */ return (list); } /* xmember - builtin function 'member' */ struct node *xmember(args) struct node *args; { return (member(args,equal)); } /* xmemq - builtin function 'memq' */ struct node *xmemq(args) struct node *args; { return (member(args,eq)); } /* member - internal member function */ LOCAL struct node *member(args,fcn) struct node *args; int (*fcn)(); { struct node *x,*list; /* get the expression to look for and the list */ x = xlarg(&args); list = xlmatch(LIST,&args); xllastarg(args); /* look for the expression */ for (; list && list->n_type == LIST; list = list->n_listnext) if ((*fcn)(x,list->n_listvalue)) return (list); /* return failure indication */ return (NULL); } /* xassoc - builtin function 'assoc' */ struct node *xassoc(args) struct node *args; { return (assoc(args,equal)); } /* xassq - builtin function 'assq' */ struct node *xassq(args) struct node *args; { return (assoc(args,eq)); } /* assoc - internal assoc function */ LOCAL struct node *assoc(args,fcn) struct node *args; int (*fcn)(); { struct node *expr,*alist,*pair; /* get the expression to look for and the association list */ expr = xlarg(&args); alist = xlmatch(LIST,&args); xllastarg(args); /* look for the expression */ return (afind(expr,alist,fcn)); } /* afind - find a pair in an association list */ LOCAL struct node *afind(expr,alist,fcn) struct node *expr,*alist; int (*fcn)(); { struct node *pair; for (; alist && alist->n_type == LIST; alist = alist->n_listnext) if ((pair = alist->n_listvalue) && pair->n_type == LIST) if ((*fcn)(expr,pair->n_listvalue)) return (pair); return (NULL); } /* xsubst - substitute one expression for another */ struct node *xsubst(args) struct node *args; { struct node *oldstk,to,from,expr,*val; /* create a new stack frame */ oldstk = xlsave(&to,&from,&expr,NULL); /* get the to value, the from value and the expression */ to.n_ptr = xlarg(&args); from.n_ptr = xlarg(&args); expr.n_ptr = xlarg(&args); xllastarg(args); /* do the substitution */ val = subst(to.n_ptr,from.n_ptr,expr.n_ptr); /* restore the previous stack frame */ xlstack = oldstk; /* return the result */ return (val); } /* subst - substitute one expression for another */ LOCAL struct node *subst(to,from,expr) struct node *to,*from,*expr; { struct node *oldstk,car,cdr,*val; if (eq(expr,from)) val = to; else if (expr == NULL || expr->n_type != LIST) val = expr; else { oldstk = xlsave(&car,&cdr,NULL); car.n_ptr = subst(to,from,expr->n_listvalue); cdr.n_ptr = subst(to,from,expr->n_listnext); val = newnode(LIST); val->n_listvalue = car.n_ptr; val->n_listnext = cdr.n_ptr; xlstack = oldstk; } return (val); } /* xsublis - substitute using an association list */ struct node *xsublis(args) struct node *args; { struct node *oldstk,alist,expr,*val; /* create a new stack frame */ oldstk = xlsave(&alist,&expr,NULL); /* get the assocation list and the expression */ alist.n_ptr = xlmatch(LIST,&args); expr.n_ptr = xlarg(&args); xllastarg(args); /* do the substitution */ val = sublis(alist.n_ptr,expr.n_ptr); /* restore the previous stack frame */ xlstack = oldstk; /* return the result */ return (val); } /* sublis - substitute using an association list */ LOCAL struct node *sublis(alist,expr) struct node *alist,*expr; { struct node *oldstk,car,cdr,*val; if (val = afind(expr,alist,eq)) val = val->n_listnext; else if (expr == NULL || expr->n_type != LIST) val = expr; else { oldstk = xlsave(&car,&cdr,NULL); car.n_ptr = sublis(alist,expr->n_listvalue); cdr.n_ptr = sublis(alist,expr->n_listnext); val = newnode(LIST); val->n_listvalue = car.n_ptr; val->n_listnext = cdr.n_ptr; xlstack = oldstk; } return (val); } /* xnth - return the nth element of a list */ struct node *xnth(args) struct node *args; { return (nth(args,FALSE)); } /* xnthcdr - return the nth cdr of a list */ struct node *xnthcdr(args) struct node *args; { return (nth(args,TRUE)); } /* nth - internal nth function */ LOCAL struct node *nth(args,cdrflag) struct node *args; int cdrflag; { struct node *list; int n; /* get n and the list */ if ((n = xlmatch(INT,&args)->n_int) < 0) xlfail("invalid argument"); if ((list = xlmatch(LIST,&args)) == NULL) xlfail("invalid argument"); xllastarg(args); /* find the nth element */ for (; n > 0; n--) { list = list->n_listnext; if (list == NULL || list->n_type != LIST) xlfail("invalid argument"); } /* return the list beginning at the nth element */ return (cdrflag ? list : list->n_listvalue); } /* xlength - return the length of a list */ struct node *xlength(args) struct node *args; { struct node *list,*val; int n; /* get the list */ list = xlmatch(LIST,&args); xllastarg(args); /* find the length */ for (n = 0; list != NULL; n++) list = list->n_listnext; /* create the value node */ val = newnode(INT); val->n_int = n; /* return the length */ return (val); } /* xmapcar - builtin function 'mapcar' */ struct node *xmapcar(args) struct node *args; { return (map(args,TRUE)); } /* xmaplist - builtin function 'maplist' */ struct node *xmaplist(args) struct node *args; { return (map(args,FALSE)); } /* map - internal mapping function */ LOCAL struct node *map(args,carflag) struct node *args; int carflag; { struct node *oldstk,fcn,lists,arglist,val,*last,*p,*x,*y; /* create a new stack frame */ oldstk = xlsave(&fcn,&lists,&arglist,&val,NULL); /* get the function to apply */ fcn.n_ptr = xlarg(&args); /* make sure there is at least one argument list */ if (args == NULL) xlfail("too few arguments"); /* get the argument lists */ while (args) { p = newnode(LIST); p->n_listnext = lists.n_ptr; lists.n_ptr = p; p->n_listvalue = xlmatch(LIST,&args); } /* if the function is a symbol, get its value */ if (fcn.n_ptr && fcn.n_ptr->n_type == SYM) fcn.n_ptr = xleval(fcn.n_ptr); /* loop through each of the argument lists */ for (;;) { /* build an argument list from the sublists */ arglist.n_ptr = NULL; for (x = lists.n_ptr; x && (y = x->n_listvalue); x = x->n_listnext) { p = newnode(LIST); p->n_listnext = arglist.n_ptr; arglist.n_ptr = p; p->n_listvalue = (carflag ? y->n_listvalue : y); x->n_listvalue = y->n_listnext; } /* quit if any of the lists were empty */ if (x) break; /* apply the function to the arguments */ p = newnode(LIST); if (val.n_ptr) last->n_listnext = p; else val.n_ptr = p; last = p; p->n_listvalue = xlapply(fcn.n_ptr,arglist.n_ptr); } /* restore the previous stack frame */ xlstack = oldstk; /* return the last test expression value */ return (val.n_ptr); } /* xrplca - replace the car of a list node */ struct node *xrplca(args) struct node *args; { struct node *list,*newcar; /* get the list and the new car */ if ((list = xlmatch(LIST,&args)) == NULL) xlfail("null list"); newcar = xlarg(&args); xllastarg(args); /* replace the car */ list->n_listvalue = newcar; /* return the list node that was modified */ return (list); } /* xrplcd - replace the cdr of a list node */ struct node *xrplcd(args) struct node *args; { struct node *list,*newcdr; /* get the list and the new cdr */ if ((list = xlmatch(LIST,&args)) == NULL) xlfail("null list"); newcdr = xlarg(&args); xllastarg(args); /* replace the cdr */ list->n_listnext = newcdr; /* return the list node that was modified */ return (list); } /* xnconc - destructively append lists */ struct node *xnconc(args) struct node *args; { struct node *list,*last,*val; /* concatenate each argument */ for (val = NULL; args; ) { /* concatenate this list */ if (list = xlmatch(LIST,&args)) { /* check for this being the first non-empty list */ if (val) last->n_listnext = list; else val = list; /* find the end of the list */ while (list && list->n_type == LIST && list->n_listnext) list = list->n_listnext; /* make sure the list ended correctly */ if (list == NULL || list->n_type != LIST) xlfail("bad list"); /* save the new last element */ last = list; } } /* return the list */ return (val); } /* xdelete - builtin function 'delete' */ struct node *xdelete(args) struct node *args; { return (delete(args,equal)); } /* xdelq - builtin function 'delq' */ struct node *xdelq(args) struct node *args; { return (delete(args,eq)); } /* delete - internal delete function */ LOCAL struct node *delete(args,fcn) struct node *args; int (*fcn)(); { struct node *x,*list,*last,*val; /* get the expression to delete and the list */ x = xlarg(&args); list = xlmatch(LIST,&args); xllastarg(args); /* delete leading matches */ while (list && list->n_type == LIST) { if (!(*fcn)(x,list->n_listvalue)) break; list = list->n_listnext; } val = last = list; /* delete embedded matches */ if (list && list->n_type == LIST) { /* skip the first non-matching element */ list = list->n_listnext; /* look for embedded matches */ while (list && list->n_type == LIST) { /* check to see if this element should be deleted */ if ((*fcn)(x,list->n_listvalue)) last->n_listnext = list->n_listnext; else last = list; /* move to the next element */ list = list->n_listnext; } } /* make sure the list ended in a nil */ if (list != NULL) xlfail("bad list"); /* return the updated list */ return (val); } /* xatom - is this an atom? */ struct node *xatom(args) struct node *args; { struct node *arg; return ((arg = xlarg(&args)) == NULL || arg->n_type != LIST ? true : NULL); } /* xsymbolp - is this an symbol? */ struct node *xsymbolp(args) struct node *args; { struct node *arg; return ((arg = xlarg(&args)) && arg->n_type == SYM ? true : NULL); } /* xnumberp - is this an number? */ struct node *xnumberp(args) struct node *args; { struct node *arg; return ((arg = xlarg(&args)) && arg->n_type == INT ? true : NULL); } /* xboundp - is this a value bound to this symbol? */ struct node *xboundp(args) struct node *args; { struct node *sym; sym = xlmatch(SYM,&args); return (sym->n_symvalue == s_unbound ? NULL : true); } /* xnull - is this null? */ struct node *xnull(args) struct node *args; { return (xlarg(&args) == NULL ? true : NULL); } /* xlistp - is this a list? */ struct node *xlistp(args) struct node *args; { struct node *arg; return ((arg = xlarg(&args)) == NULL || arg->n_type == LIST ? true : NULL); } /* xconsp - is this a cons? */ struct node *xconsp(args) struct node *args; { struct node *arg; return ((arg = xlarg(&args)) != NULL && arg->n_type == LIST ? true : NULL); } /* xeq - are these equal? */ struct node *xeq(args) struct node *args; { struct node *arg1,*arg2; /* get the two arguments */ arg1 = xlarg(&args); arg2 = xlarg(&args); xllastarg(args); /* compare the arguments */ return (eq(arg1,arg2) ? true : NULL); } /* eq - internal eq function */ LOCAL int eq(arg1,arg2) struct node *arg1,*arg2; { /* compare the arguments */ if (arg1 != NULL && arg1->n_type == INT && arg2 != NULL && arg2->n_type == INT) return (arg1->n_int == arg2->n_int); else return (arg1 == arg2); } /* xequal - are these equal? */ struct node *xequal(args) struct node *args; { struct node *arg1,*arg2; /* get the two arguments */ arg1 = xlarg(&args); arg2 = xlarg(&args); xllastarg(args); /* compare the arguments */ return (equal(arg1,arg2) ? true : NULL); } /* equal - internal equal function */ LOCAL int equal(arg1,arg2) struct node *arg1,*arg2; { /* compare the arguments */ if (eq(arg1,arg2)) return (TRUE); else if (arg1 && arg1->n_type == LIST && arg2 && arg2->n_type == LIST) return (equal(arg1->n_listvalue,arg2->n_listvalue) && equal(arg1->n_listnext, arg2->n_listnext)); else return (FALSE); }