home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / drdobbs / 1991 / 08 / xscheme / xsfun2.c < prev    next >
Text File  |  1991-06-04  |  29KB  |  1,251 lines
  1. /* xsfun2.c - xscheme built-in functions - part 2 */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* external variables */
  9. extern jmp_buf top_level;
  10. extern LVAL eof_object,true;
  11. extern LVAL xlfun,xlenv,xlval;
  12. extern int prbreadth,prdepth;
  13. extern FILE *tfp;
  14.  
  15. /* external routines */
  16. extern void xlprin1(),xlprinc();
  17.  
  18. /* forward declarations */
  19. #ifdef __STDC__
  20. static void do_maploop(LVAL last);
  21. static void do_forloop(void);
  22. static void do_withfile(int flags,char *mode);
  23. static void do_load(LVAL print);
  24. static void do_loadloop(LVAL print);
  25. static LVAL setit(int *pvar);
  26. static LVAL openfile(int flags,char *mode);
  27. static LVAL strcompare(int fcn,int icase);
  28. static LVAL chrcompare(int fcn,int icase);
  29. #else
  30. static LVAL setit();
  31. static LVAL openfile();
  32. static LVAL strcompare();
  33. static LVAL chrcompare();
  34. #endif
  35.  
  36. /* xapply - built-in function 'apply' */
  37. void xapply()
  38. {
  39.     LVAL args,*p;
  40.  
  41.     /* get the function and argument list */
  42.     xlval = xlgetarg();
  43.     args = xlgalist();
  44.     xllastarg();
  45.  
  46.     /* get the argument count and make space on the stack */
  47.     xlargc = length(args);
  48.     check(xlargc);
  49.  
  50.     /* copy the arguments onto the stack */
  51.     for (xlsp -= xlargc, p = xlsp; consp(args); args = cdr(args))
  52.     *p++ = car(args);
  53.  
  54.     /* apply the function to the arguments */
  55.     xlapply();
  56. }
  57.  
  58. /* xcallcc - built-in function 'call-with-current-continuation' */
  59. void xcallcc()
  60. {
  61.     LVAL cont,*src,*dst;
  62.     int size;
  63.  
  64.     /* get the function to call */
  65.     xlval = xlgetarg();
  66.     xllastarg();
  67.  
  68.     /* create a continuation object */
  69.     size = (int)(xlstktop - xlsp);
  70.     cont = newcontinuation(size);
  71.     for (src = xlsp, dst = &cont->n_vdata[0]; --size >= 0; )
  72.     *dst++ = *src++;
  73.  
  74.     /* setup the argument list */
  75.     cpush(cont);
  76.     xlargc = 1;
  77.  
  78.     /* apply the function */
  79.     xlapply();
  80. }
  81.  
  82. /* xmap - built-in function 'map' */
  83. void xmap()
  84. {
  85.     if (xlargc < 2) xltoofew();
  86.     xlval = NIL;
  87.     do_maploop(NIL);
  88. }
  89.  
  90. /* do_maploop - setup for the next application */
  91. static void do_maploop(last)
  92.   LVAL last;
  93. {
  94.     extern LVAL cs_map1;
  95.     LVAL *oldsp,*p,x;
  96.     int cnt;
  97.  
  98.     /* get a pointer to the end of the argument list */
  99.     p = &xlsp[xlargc];
  100.     oldsp = xlsp;
  101.  
  102.     /* save a continuation */
  103.     if (xlval) { check(5); push(xlval); push(last); }
  104.     else       { check(4); push(NIL); }
  105.     push(cvfixnum((FIXTYPE)xlargc));
  106.     push(cs_map1);
  107.     push(xlenv);
  108.  
  109.     /* build the argument list for the next application */
  110.     for (cnt = xlargc; --cnt >= 1; ) {
  111.     x = *--p;
  112.     if (consp(x)) {
  113.         cpush(car(x));
  114.         *p = cdr(x);
  115.     }
  116.     else {
  117.         xlsp = oldsp;
  118.         drop(xlargc);
  119.         xlreturn();
  120.         return;
  121.     }
  122.     }
  123.     xlval = *--p;    /* get the function to apply */
  124.     xlargc -= 1;    /* count shouldn't include the function itself */
  125.     xlapply();        /* apply the function */
  126. }
  127.  
  128. /* xmap1 - continuation for xmap */
  129. void xmap1()
  130. {
  131.     LVAL last,tmp;
  132.  
  133.     /* get the argument count */
  134.     tmp = pop();
  135.  
  136.     /* get the tail of the value list */
  137.     if ((last = pop()) != NIL) {
  138.     rplacd(last,cons(xlval,NIL));    /* add the new value to the tail */
  139.     last = cdr(last);        /* remember the new tail */
  140.     xlval = pop();            /* restore the head of the list */
  141.     }
  142.     else
  143.     xlval = last = cons(xlval,NIL);    /* build the initial value list */
  144.     
  145.     /* convert the argument count and loop */
  146.     xlargc = (int)getfixnum(tmp);
  147.     do_maploop(last);
  148. }
  149.  
  150. /* xforeach - built-in function 'for-each' */
  151. void xforeach()
  152. {
  153.     if (xlargc < 2) xltoofew();
  154.     do_forloop();
  155. }
  156.  
  157. /* do_forloop - setup for the next application */
  158. static void do_forloop()
  159. {
  160.     extern LVAL cs_foreach1;
  161.     LVAL *oldsp,*p,x;
  162.     int cnt;
  163.  
  164.     /* get a pointer to the end of the argument list */
  165.     p = &xlsp[xlargc];
  166.     oldsp = xlsp;
  167.  
  168.     /* save a continuation */
  169.     check(3);
  170.     push(cvfixnum((FIXTYPE)xlargc));
  171.     push(cs_foreach1);
  172.     push(xlenv);
  173.  
  174.     /* build the argument list for the next application */
  175.     for (cnt = xlargc; --cnt >= 1; ) {
  176.     x = *--p;
  177.     if (consp(x)) {
  178.         cpush(car(x));
  179.         *p = cdr(x);
  180.     }
  181.     else {
  182.         xlsp = oldsp;
  183.         drop(xlargc);
  184.         xlval = NIL;
  185.         xlreturn();
  186.         return;
  187.     }
  188.     }
  189.     xlval = *--p;    /* get the function to apply */
  190.     xlargc -= 1;    /* count shouldn't include the function itself */
  191.     xlapply();        /* apply the function */
  192. }
  193.  
  194. /* xforeach1 - continuation for xforeach */
  195. void xforeach1()
  196. {
  197.     LVAL tmp;
  198.  
  199.     /* get the argument count */
  200.     tmp = pop();
  201.  
  202.     /* convert the argument count and loop */
  203.     xlargc = (int)getfixnum(tmp);
  204.     do_forloop();
  205. }
  206.  
  207. /* xcallwi - built-in function 'call-with-input-file' */
  208. void xcallwi()
  209. {
  210.     do_withfile(PF_INPUT,"r");
  211. }
  212.  
  213. /* xcallwo - built-in function 'call-with-output-file' */
  214. void xcallwo()
  215. {
  216.     do_withfile(PF_OUTPUT,"w");
  217. }
  218.  
  219. /* do_withfile - handle the 'call-with-xxx-file' functions */
  220. static void do_withfile(flags,mode)
  221.   int flags; char *mode;
  222. {
  223.     extern LVAL cs_withfile1;
  224.     extern FILE *osaopen();
  225.     LVAL name,file;
  226.     FILE *fp;
  227.  
  228.     /* get the function to call */
  229.     name = xlgastring();
  230.     xlval = xlgetarg();
  231.     xllastarg();
  232.  
  233.     /* create a file object */
  234.     file = cvport(NULL,flags);
  235.     if ((fp = osaopen(getstring(name),mode)) == NULL)
  236.     xlerror("can't open file",name);
  237.     setfile(file,fp);
  238.  
  239.     /* save a continuation */
  240.     check(3);
  241.     push(file);
  242.     push(cs_withfile1);
  243.     push(xlenv);
  244.  
  245.     /* setup the argument list */
  246.     cpush(file);
  247.     xlargc = 1;
  248.  
  249.     /* apply the function */
  250.     xlapply();
  251. }
  252.  
  253. /* xwithfile1 - continuation for xcallwi and xcallwo */
  254. void xwithfile1()
  255. {
  256.     osclose(getfile(top()));
  257.     setfile(pop(),NULL);
  258.     xlreturn();
  259. }
  260.  
  261. /* xload - built-in function 'load' */
  262. void xload()
  263. {
  264.     do_load(NIL);
  265. }
  266.  
  267. /* xloadnoisily - built-in function 'load-noisily' */
  268. void xloadnoisily()
  269. {
  270.     do_load(true);
  271. }
  272.  
  273. /* do_load - open the file and setup the load loop */
  274. static void do_load(print)
  275.   LVAL print;
  276. {
  277.     extern FILE *osaopen();
  278.     LVAL file;
  279.     FILE *fp;
  280.  
  281.     /* get the function to call */
  282.     xlval = xlgastring();
  283.     xllastarg();
  284.  
  285.     /* create a file object */
  286.     file = cvport(NULL,PF_INPUT);
  287.     if ((fp = osaopen(getstring(xlval),"r")) == NULL) {
  288.     xlval = NIL;
  289.     xlreturn();
  290.     return;
  291.     }
  292.     setfile(file,fp);
  293.     xlval = file;
  294.  
  295.     /* do the first read */
  296.     do_loadloop(print);
  297. }
  298.  
  299. /* do_loadloop - read the next expression and setup to evaluate it */
  300. static void do_loadloop(print)
  301.   LVAL print;
  302. {
  303.     extern LVAL cs_load1,s_eval;
  304.     LVAL expr;
  305.     
  306.     /* try to read the next expression from the file */
  307.     if (xlread(xlval,&expr)) {
  308.  
  309.     /* save a continuation */
  310.     check(4);
  311.     push(xlval);
  312.     push(print);
  313.     push(cs_load1);
  314.     push(xlenv);
  315.  
  316.     /* setup the argument list */
  317.     xlval = getvalue(s_eval);
  318.     cpush(expr);
  319.     xlargc = 1;
  320.  
  321.     /* apply the function */
  322.     xlapply();
  323.     }
  324.     else {
  325.     osclose(getfile(xlval));
  326.     setfile(xlval,NULL);
  327.     xlval = true;
  328.     xlreturn();
  329.     }
  330. }
  331.  
  332. /* xload1 - continuation for xload */
  333. void xload1()
  334. {
  335.     LVAL print;
  336.  
  337.     /* print the value if the print variable is set */
  338.     if ((print = pop()) != NIL) {
  339.     xlprin1(xlval,curoutput());
  340.     xlterpri(curoutput());
  341.     }
  342.     xlval = pop();
  343.     
  344.     /* setup for the next read */
  345.     do_loadloop(print);
  346. }
  347.  
  348. /* xforce - built-in function 'force' */
  349. void xforce()
  350. {
  351.     extern LVAL cs_force1;
  352.  
  353.     /* get the promise */
  354.     xlval = xlgetarg();
  355.     xllastarg();
  356.  
  357.     /* check for a promise */
  358.     if (promisep(xlval)) {
  359.  
  360.     /* force the promise the first time */
  361.     if ((xlfun = getpproc(xlval)) != NIL) {
  362.         check(3);
  363.         push(xlval);
  364.         push(cs_force1);
  365.         push(xlenv);
  366.         xlval = xlfun;
  367.         xlargc = 0;
  368.         xlapply();
  369.     }
  370.  
  371.     /* return the saved value if the promise has already been forced */
  372.     else {
  373.         xlval = getpvalue(xlval);
  374.         xlreturn();
  375.     }
  376.     
  377.     }
  378.     
  379.     /* otherwise, just return the argument */
  380.     else
  381.     xlreturn();
  382. }
  383.  
  384. /* xforce1 - continuation for xforce */
  385. void xforce1()
  386. {
  387.     LVAL promise;
  388.     promise = pop();
  389.     setpvalue(promise,xlval);
  390.     setpproc(promise,NIL);
  391.     xlreturn();
  392. }
  393.  
  394. /* xsymstr - built-in function 'symbol->string' */
  395. LVAL xsymstr()
  396. {
  397.     xlval = xlgasymbol();
  398.     xllastarg();
  399.     return (getpname(xlval));
  400. }
  401.  
  402. /* xstrsym - built-in function 'string->symbol' */
  403. LVAL xstrsym()
  404. {
  405.     xlval = xlgastring();
  406.     xllastarg();
  407.     return (xlenter(getstring(xlval)));
  408. }
  409.  
  410. /* xread - built-in function 'read' */
  411. LVAL xread()
  412. {
  413.     LVAL fptr,val;
  414.  
  415.     /* get file pointer and eof value */
  416.     fptr = (moreargs() ? xlgaiport() : curinput());
  417.     xllastarg();
  418.  
  419.     /* read an expression */
  420.     if (!xlread(fptr,&val))
  421.     val = eof_object;
  422.  
  423.     /* return the expression */
  424.     return (val);
  425. }
  426.  
  427. /* xrdchar - built-in function 'read-char' */
  428. LVAL xrdchar()
  429. {
  430.     LVAL fptr;
  431.     int ch;
  432.     fptr = (moreargs() ? xlgaiport() : curinput());
  433.     xllastarg();
  434.     return ((ch = xlgetc(fptr)) == EOF ? eof_object : cvchar(ch));
  435. }
  436.  
  437. /* xrdbyte - built-in function 'read-byte' */
  438. LVAL xrdbyte()
  439. {
  440.     LVAL fptr;
  441.     int ch;
  442.     fptr = (moreargs() ? xlgaiport() : curinput());
  443.     xllastarg();
  444.     return ((ch = xlgetc(fptr)) == EOF ? eof_object : cvfixnum((FIXTYPE)ch));
  445. }
  446.  
  447. /* xrdshort - built-in function 'read-short' */
  448. LVAL xrdshort()
  449. {
  450.     unsigned char *p;
  451.     short int val=0;
  452.     LVAL fptr;
  453.     int ch,n;
  454.     fptr = (moreargs() ? xlgaiport() : curinput());
  455.     xllastarg();
  456.     for (n = sizeof(short int), p = (unsigned char *)&val; --n >= 0; ) {
  457.         if ((ch = xlgetc(fptr)) == EOF)
  458.         return (eof_object);
  459.         *p++ = ch;
  460.     }
  461.     return (cvfixnum((FIXTYPE)val));
  462. }
  463.  
  464. /* xrdlong - built-in function 'read-long' */
  465. LVAL xrdlong()
  466. {
  467.     unsigned char *p;
  468.     long int val=0;
  469.     LVAL fptr;
  470.     int ch,n;
  471.     fptr = (moreargs() ? xlgaiport() : curinput());
  472.     xllastarg();
  473.     for (n = sizeof(long int), p = (unsigned char *)&val; --n >= 0; ) {
  474.         if ((ch = xlgetc(fptr)) == EOF)
  475.         return (eof_object);
  476.         *p++ = ch;
  477.     }
  478.     return (cvfixnum((FIXTYPE)val));
  479. }
  480.  
  481. /* xeofobjectp - built-in function 'eof-object?' */
  482. LVAL xeofobjectp()
  483. {
  484.     LVAL arg;
  485.     arg = xlgetarg();
  486.     xllastarg();
  487.     return (arg == eof_object ? true : NIL);
  488. }
  489.  
  490. /* xwrite - built-in function 'write' */
  491. LVAL xwrite()
  492. {
  493.     LVAL fptr,val;
  494.  
  495.     /* get expression to print and file pointer */
  496.     val = xlgetarg();
  497.     fptr = (moreargs() ? xlgaoport() : curoutput());
  498.     xllastarg();
  499.  
  500.     /* print the value */
  501.     xlprin1(val,fptr);
  502.     return (true);
  503. }
  504.  
  505. /* xprint - built-in function 'print' */
  506. LVAL xprint()
  507. {
  508.     LVAL fptr,val;
  509.  
  510.     /* get expression to print and file pointer */
  511.     val = xlgetarg();
  512.     fptr = (moreargs() ? xlgaoport() : curoutput());
  513.     xllastarg();
  514.  
  515.     /* print the value */
  516.     xlprin1(val,fptr);
  517.     xlterpri(fptr);
  518.     return (true);
  519. }
  520.  
  521. /* xwrchar - built-in function 'write-char' */
  522. LVAL xwrchar()
  523. {
  524.     LVAL fptr,ch;
  525.     ch = xlgachar();
  526.     fptr = (moreargs() ? xlgaoport() : curoutput());
  527.     xllastarg();
  528.     xlputc(fptr,(int)getchcode(ch));
  529.     return (true);
  530. }
  531.  
  532. /* xwrbyte - built-in function 'write-byte' */
  533. LVAL xwrbyte()
  534. {
  535.     LVAL fptr,ch;
  536.     ch = xlgafixnum();
  537.     fptr = (moreargs() ? xlgaoport() : curoutput());
  538.     xllastarg();
  539.     xlputc(fptr,(int)getfixnum(ch));
  540.     return (true);
  541. }
  542.  
  543. /* xwrshort - built-in function 'write-short' */
  544. LVAL xwrshort()
  545. {
  546.     unsigned char *p;
  547.     short int val;
  548.     LVAL fptr,v;
  549.     int n;
  550.     v = xlgafixnum(); val = (short int)getfixnum(v);
  551.     fptr = (moreargs() ? xlgaoport() : curoutput());
  552.     xllastarg();
  553.     for (n = sizeof(short int), p = (unsigned char *)&val; --n >= 0; )
  554.         xlputc(fptr,*p++);
  555.     return (true);
  556. }
  557.  
  558. /* xwrlong - built-in function 'write-long' */
  559. LVAL xwrlong()
  560. {
  561.     unsigned char *p;
  562.     long int val;
  563.     LVAL fptr,v;
  564.     int n;
  565.     v = xlgafixnum(); val = (long int)getfixnum(v);
  566.     fptr = (moreargs() ? xlgaoport() : curoutput());
  567.     xllastarg();
  568.     for (n = sizeof(long int), p = (unsigned char *)&val; --n >= 0; )
  569.         xlputc(fptr,*p++);
  570.     return (true);
  571. }
  572.  
  573. /* xdisplay - built-in function 'display' */
  574. LVAL xdisplay()
  575. {
  576.     LVAL fptr,val;
  577.  
  578.     /* get expression to print and file pointer */
  579.     val = xlgetarg();
  580.     fptr = (moreargs() ? xlgaoport() : curoutput());
  581.     xllastarg();
  582.  
  583.     /* print the value */
  584.     xlprinc(val,fptr);
  585.     return (true);
  586. }
  587.  
  588. /* xnewline - terminate the current print line */
  589. LVAL xnewline()
  590. {
  591.     LVAL fptr;
  592.  
  593.     /* get file pointer */
  594.     fptr = (moreargs() ? xlgaoport() : curoutput());
  595.     xllastarg();
  596.  
  597.     /* terminate the print line and return nil */
  598.     xlterpri(fptr);
  599.     return (true);
  600. }
  601.  
  602. /* xprbreadth - set the maximum number of elements to be printed */
  603. LVAL xprbreadth()
  604. {
  605.     return (setit(&prbreadth));
  606. }
  607.  
  608. /* xprdepth - set the maximum depth of nested lists to be printed */
  609. LVAL xprdepth()
  610. {
  611.     return (setit(&prdepth));
  612. }
  613.  
  614. /* setit - common routine for prbreadth/prdepth */
  615. static LVAL setit(pvar)
  616.   int *pvar;
  617. {
  618.     LVAL arg;
  619.  
  620.     /* get the optional argument */
  621.     if (moreargs()) {
  622.     arg = xlgetarg();
  623.     xllastarg();
  624.     *pvar = (fixp(arg) ? (int)getfixnum(arg) : -1);
  625.     }
  626.  
  627.     /* return the value of the variable */
  628.     return (*pvar >= 0 ? cvfixnum((FIXTYPE)*pvar) : NIL);
  629. }
  630.  
  631. /* xopeni - built-in function 'open-input-file' */
  632. LVAL xopeni()
  633. {
  634.     return (openfile(PF_INPUT,"r"));
  635. }
  636.  
  637. /* xopeno - built-in function 'open-output-file' */
  638. LVAL xopeno()
  639. {
  640.     return (openfile(PF_OUTPUT,"w"));
  641. }
  642.  
  643. /* xopena - built-in function 'open-append-file' */
  644. LVAL xopena()
  645. {
  646.     return (openfile(PF_OUTPUT,"a"));
  647. }
  648.  
  649. /* xopenu - built-in function 'open-update-file' */
  650. LVAL xopenu()
  651. {
  652.     return (openfile(PF_INPUT|PF_OUTPUT,"r+"));
  653. }
  654.  
  655. /* openfile - open an ascii or binary file */
  656. static LVAL openfile(flags,mode)
  657.   int flags; char *mode;
  658. {
  659.     extern FILE *osaopen(),*osbopen();
  660.     LVAL file,modekey;
  661.     char *name;
  662.     FILE *fp;
  663.  
  664.     /* get the file name and direction */
  665.     name = getstring(xlgastring());
  666.     modekey = (moreargs() ? xlgasymbol() : NIL);
  667.     xllastarg();
  668.  
  669.     /* check for binary mode */
  670.     if (modekey != NIL) {
  671.     if (modekey == xlenter("BINARY"))
  672.         flags |= PF_BINARY;
  673.     else if (modekey != xlenter("TEXT"))
  674.         xlerror("unrecognized open mode",modekey);
  675.     }
  676.  
  677.     /* try to open the file */
  678.     file = cvport(NULL,flags);
  679.     fp = ((flags & PF_BINARY) == 0 ? osaopen(name,mode) : osbopen(name,mode));
  680.     if (fp == NULL)
  681.     return (NIL);
  682.     setfile(file,fp);
  683.     return (file);
  684. }
  685.  
  686. /* xclose - built-in function 'close-port' */
  687. LVAL xclose()
  688. {
  689.     LVAL fptr;
  690.     fptr = xlgaport();
  691.     xllastarg();
  692.     if (getfile(fptr))
  693.     osclose(getfile(fptr));
  694.     setfile(fptr,NULL);
  695.     return (NIL);
  696. }
  697.  
  698. /* xclosei - built-in function 'close-input-port' */
  699. LVAL xclosei()
  700. {
  701.     LVAL fptr;
  702.     fptr = xlgaiport();
  703.     xllastarg();
  704.     if (getfile(fptr))
  705.     osclose(getfile(fptr));
  706.     setfile(fptr,NULL);
  707.     return (NIL);
  708. }
  709.  
  710. /* xcloseo - built-in function 'close-output-port' */
  711. LVAL xcloseo()
  712. {
  713.     LVAL fptr;
  714.     fptr = xlgaoport();
  715.     xllastarg();
  716.     if (getfile(fptr))
  717.     osclose(getfile(fptr));
  718.     setfile(fptr,NULL);
  719.     return (NIL);
  720. }
  721.  
  722. /* xgetfposition - built-in function 'get-file-position' */
  723. LVAL xgetfposition()
  724. {
  725.     extern long ostell();
  726.     LVAL fptr;
  727.     fptr = xlgaport();
  728.     xllastarg();
  729.     return (cvfixnum(ostell(getfile(fptr))));
  730. }
  731.  
  732. /* xsetfposition - built-in function 'set-file-position!' */
  733. LVAL xsetfposition()
  734. {
  735.     LVAL fptr,val;
  736.     long position;
  737.     int whence;
  738.     fptr = xlgaport();
  739.     val = xlgafixnum(); position = getfixnum(val);
  740.     val = xlgafixnum(); whence = (int)getfixnum(val);
  741.     xllastarg();
  742.     return (osseek(getfile(fptr),position,whence) == 0 ? true : NIL);
  743. }
  744.  
  745. /* xcurinput - built-in function 'current-input-port' */
  746. LVAL xcurinput()
  747. {
  748.     xllastarg();
  749.     return (curinput());
  750. }
  751.  
  752. /* xcuroutput - built-in function 'current-output-port' */
  753. LVAL xcuroutput()
  754. {
  755.     xllastarg();
  756.     return (curoutput());
  757. }
  758.  
  759. /* xportp - built-in function 'port?' */
  760. LVAL xportp()
  761. {
  762.     LVAL arg;
  763.     arg = xlgetarg();
  764.     xllastarg();
  765.     return (portp(arg) ? true : NIL);
  766. }
  767.  
  768. /* xinputportp - built-in function 'input-port?' */
  769. LVAL xinputportp()
  770. {
  771.     LVAL arg;
  772.     arg = xlgetarg();
  773.     xllastarg();
  774.     return (iportp(arg) ? true : NIL);
  775. }
  776.  
  777. /* xoutputportp - built-in function 'output-port?' */
  778. LVAL xoutputportp()
  779. {
  780.     LVAL arg;
  781.     arg = xlgetarg();
  782.     xllastarg();
  783.     return (oportp(arg) ? true : NIL);
  784. }
  785.  
  786. /* xtranson - built-in function 'transcript-on' */
  787. LVAL xtranson()
  788. {
  789.     extern FILE *osaopen();
  790.     char *name;
  791.  
  792.     /* get the file name and direction */
  793.     name = getstring(xlgastring());
  794.     xllastarg();
  795.  
  796.     /* close any currently open transcript file */
  797.     if (tfp) { osclose(tfp); tfp = NULL; }
  798.  
  799.     /* try to open the file */
  800.     return ((tfp = osaopen(name,"w")) == NULL ? NIL : true);
  801. }
  802.  
  803. /* xtransoff - built-in function 'transcript-off' */
  804. LVAL xtransoff()
  805. {
  806.     /* make sure there aren't any arguments */
  807.     xllastarg();
  808.  
  809.     /* make sure the transcript is open */
  810.     if (tfp == NULL)
  811.     return (NIL);
  812.  
  813.     /* close the transcript and return successfully */
  814.     osclose(tfp); tfp = NULL;
  815.     return (true);
  816. }
  817.  
  818. /* xstrlen - built-in function 'string-length' */
  819. LVAL xstrlen()
  820. {
  821.     LVAL str;
  822.     str = xlgastring();
  823.     xllastarg();
  824.     return (cvfixnum((FIXTYPE)(getslength(str)-1)));
  825. }
  826.  
  827. /* xstrnullp - built-in function 'string-null?' */
  828. LVAL xstrnullp()
  829. {
  830.     LVAL str;
  831.     str = xlgastring();
  832.     xllastarg();
  833.     return (getslength(str) == 1 ? true : NIL);
  834. }
  835.  
  836. /* xstrappend - built-in function 'string-append' */
  837. LVAL xstrappend()
  838. {
  839.     LVAL *savesp,tmp,val;
  840.     char *str;
  841.     int saveargc,len;
  842.  
  843.     /* save the argument list */
  844.     saveargc = xlargc;
  845.     savesp = xlsp;
  846.  
  847.     /* find the length of the new string */
  848.     for (len = 0; moreargs(); ) {
  849.     tmp = xlgastring();
  850.     len += (int)getslength(tmp) - 1;
  851.     }
  852.  
  853.     /* restore the argument list */
  854.     xlargc = saveargc;
  855.     xlsp = savesp;
  856.     
  857.     /* create the result string */
  858.     val = newstring(len+1);
  859.     str = getstring(val);
  860.  
  861.     /* combine the strings */
  862.     for (*str = '\0'; moreargs(); ) {
  863.     tmp = nextarg();
  864.     strcat(str,getstring(tmp));
  865.     }
  866.  
  867.     /* return the new string */
  868.     return (val);
  869. }
  870.  
  871. /* xstrref - built-in function 'string-ref' */
  872. LVAL xstrref()
  873. {
  874.     LVAL str,num;
  875.     int n;
  876.  
  877.     /* get the string and the index */
  878.     str = xlgastring();
  879.     num = xlgafixnum();
  880.     xllastarg();
  881.  
  882.     /* range check the index */
  883.     if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1)
  884.     xlerror("index out of range",num);
  885.  
  886.     /* return the character */
  887.     return (cvchar(getstring(str)[n]));
  888. }
  889.  
  890. /* xsubstring - built-in function 'substring' */
  891. LVAL xsubstring()
  892. {
  893.     char *srcp,*dstp;
  894.     int start,end,len;
  895.     LVAL src,dst;
  896.  
  897.     /* get string and starting and ending positions */
  898.     src = xlgastring();
  899.  
  900.     /* get the starting position */
  901.     dst = xlgafixnum(); start = (int)getfixnum(dst);
  902.     if (start < 0 || start > getslength(src) - 1)
  903.     xlerror("index out of range",dst);
  904.  
  905.     /* get the ending position */
  906.     if (moreargs()) {
  907.     dst = xlgafixnum(); end = (int)getfixnum(dst);
  908.     if (end < 0 || end > getslength(src) - 1)
  909.         xlerror("index out of range",dst);
  910.     }
  911.     else
  912.     end = getslength(src) - 1;
  913.     xllastarg();
  914.  
  915.     /* setup the source pointer */
  916.     srcp = getstring(src) + start;
  917.     len = end - start;
  918.  
  919.     /* make a destination string and setup the pointer */
  920.     dst = newstring(len+1);
  921.     dstp = getstring(dst);
  922.  
  923.     /* copy the source to the destination */
  924.     while (--len >= 0)
  925.     *dstp++ = *srcp++;
  926.     *dstp = '\0';
  927.  
  928.     /* return the substring */
  929.     return (dst);
  930. }
  931.  
  932. /* xstrlist - built-in function 'string->list' */
  933. LVAL xstrlist()
  934. {
  935.     char *p;
  936.     LVAL str;
  937.     int size;
  938.  
  939.     /* get the vector */
  940.     str = xlgastring();
  941.     xllastarg();
  942.     
  943.     /* make a list from the vector */
  944.     cpush(str);
  945.     size = getslength(str)-1;
  946.     for (xlval = NIL, p = &getstring(str)[size]; --size >= 0; )
  947.     xlval = cons(cvchar(*--p),xlval);
  948.     drop(1);
  949.     return (xlval);
  950. }
  951.  
  952. /* xliststring - built-in function 'list->string' */
  953. LVAL xliststring()
  954. {
  955.     char *p;
  956.     LVAL str;
  957.     int size;
  958.  
  959.     /* get the list */
  960.     xlval = xlgalist();
  961.     xllastarg();
  962.  
  963.     /* make a vector from the list */
  964.     size = length(xlval);
  965.     str = newstring(size+1);
  966.     for (p = getstring(str); --size >= 0; xlval = cdr(xlval))
  967.     if (charp(car(xlval)))
  968.         *p++ = getchcode(car(xlval));
  969.     else
  970.         xlbadtype(car(xlval));
  971.     *p = '\0';
  972.     return (str);
  973. }
  974.  
  975. /* string comparision functions */
  976. LVAL xstrlss() { return (strcompare('<',FALSE)); } /* string<? */
  977. LVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<=? */
  978. LVAL xstreql() { return (strcompare('=',FALSE)); } /* string=? */
  979. LVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>=? */
  980. LVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string>? */
  981.  
  982. /* string comparison functions (case insensitive) */
  983. LVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-ci<? */
  984. LVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-ci<=? */
  985. LVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-ci=? */
  986. LVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-ci>=? */
  987. LVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-ci>? */
  988.  
  989. /* strcompare - compare strings */
  990. static LVAL strcompare(fcn,icase)
  991.   int fcn,icase;
  992. {
  993.     int start1,end1,start2,end2,ch1,ch2;
  994.     char *p1,*p2;
  995.     LVAL str1,str2;
  996.  
  997.     /* get the strings */
  998.     str1 = xlgastring();
  999.     str2 = xlgastring();
  1000.     xllastarg();
  1001.  
  1002.     /* setup the string pointers */
  1003.     p1 = getstring(str1); start1 = 0; end1 = getslength(str1);
  1004.     p2 = getstring(str2); start2 = 0; end2 = getslength(str2);
  1005.  
  1006.     /* compare the strings */
  1007.     for (; start1 < end1 && start2 < end2; ++start1,++start2) {
  1008.     ch1 = *p1++;
  1009.     ch2 = *p2++;
  1010.     if (icase) {
  1011.         if (isupper(ch1)) ch1 = tolower(ch1);
  1012.         if (isupper(ch2)) ch2 = tolower(ch2);
  1013.     }
  1014.     if (ch1 != ch2)
  1015.         switch (fcn) {
  1016.         case '<':    return (ch1 < ch2 ? true : NIL);
  1017.         case 'L':    return (ch1 <= ch2 ? true : NIL);
  1018.         case '=':    return (NIL);
  1019.         case 'G':    return (ch1 >= ch2 ? true : NIL);
  1020.         case '>':    return (ch1 > ch2 ? true : NIL);
  1021.         }
  1022.     }
  1023.  
  1024.     /* check the termination condition */
  1025.     switch (fcn) {
  1026.     case '<':    return (start1 >= end1 && start2 < end2 ? true : NIL);
  1027.     case 'L':    return (start1 >= end1 ? true : NIL);
  1028.     case '=':    return (start1 >= end1 && start2 >= end2 ? true : NIL);
  1029.     case 'G':    return (start2 >= end2 ? true : NIL);
  1030.     case '>':    return (start2 >= end2 && start1 < end1 ? true : NIL);
  1031.     }
  1032.     return (NIL); /* never reached */
  1033. }
  1034.  
  1035. /* xcharint - built-in function 'char->integer' */
  1036. LVAL xcharint()
  1037. {
  1038.     LVAL arg;
  1039.     arg = xlgachar();
  1040.     xllastarg();
  1041.     return (cvfixnum((FIXTYPE)getchcode(arg)));
  1042. }
  1043.  
  1044. /* xintchar - built-in function 'integer->char' */
  1045. LVAL xintchar()
  1046. {
  1047.     LVAL arg;
  1048.     arg = xlgafixnum();
  1049.     xllastarg();
  1050.     return (cvchar((int)getfixnum(arg)));
  1051. }
  1052.  
  1053. /* character comparision functions */
  1054. LVAL xchrlss() { return (chrcompare('<',FALSE)); } /* char<? */
  1055. LVAL xchrleq() { return (chrcompare('L',FALSE)); } /* char<=? */
  1056. LVAL xchreql() { return (chrcompare('=',FALSE)); } /* char=? */
  1057. LVAL xchrgeq() { return (chrcompare('G',FALSE)); } /* char>=? */
  1058. LVAL xchrgtr() { return (chrcompare('>',FALSE)); } /* char>? */
  1059.  
  1060. /* character comparision functions (case insensitive) */
  1061. LVAL xchrilss() { return (chrcompare('<',TRUE)); } /* char-ci<? */
  1062. LVAL xchrileq() { return (chrcompare('L',TRUE)); } /* char-ci<=? */
  1063. LVAL xchrieql() { return (chrcompare('=',TRUE)); } /* char-ci=? */
  1064. LVAL xchrigeq() { return (chrcompare('G',TRUE)); } /* char-ci>=? */
  1065. LVAL xchrigtr() { return (chrcompare('>',TRUE)); } /* char-ci>? */
  1066.  
  1067. /* chrcompare - compare characters */
  1068. static LVAL chrcompare(fcn,icase)
  1069.   int fcn,icase;
  1070. {
  1071.     int ch1,ch2;
  1072.     LVAL arg;
  1073.     
  1074.     /* get the characters */
  1075.     arg = xlgachar(); ch1 = getchcode(arg);
  1076.     arg = xlgachar(); ch2 = getchcode(arg);
  1077.     xllastarg();
  1078.  
  1079.     /* convert to lowercase if case insensitive */
  1080.     if (icase) {
  1081.     if (isupper(ch1)) ch1 = tolower(ch1);
  1082.     if (isupper(ch2)) ch2 = tolower(ch2);
  1083.     }
  1084.  
  1085.     /* compare the characters */
  1086.     switch (fcn) {
  1087.     case '<':    return (ch1 < ch2 ? true : NIL);
  1088.     case 'L':    return (ch1 <= ch2 ? true : NIL);
  1089.     case '=':    return (ch1 == ch2 ? true : NIL);
  1090.     case 'G':    return (ch1 >= ch2 ? true : NIL);
  1091.     case '>':    return (ch1 > ch2 ? true : NIL);
  1092.     }
  1093.     return (NIL); /* never reached */
  1094. }
  1095.  
  1096. /* xcompile - built-in function 'compile' */
  1097. LVAL xcompile()
  1098. {
  1099.     extern LVAL xlcompile();
  1100.     LVAL env;
  1101.  
  1102.     /* get the expression to compile and the environment */
  1103.     xlval = xlgetarg();
  1104.     env = (moreargs() ? xlgaenv() : NIL);
  1105.     xllastarg();
  1106.     
  1107.     /* build the closure */
  1108.     cpush(env);
  1109.     xlval = xlcompile(xlval,env);
  1110.     xlval = cvclosure(xlval,env);
  1111.     drop(1);
  1112.     return (xlval);
  1113. }
  1114.  
  1115. /* xdecompile - built-in function 'decompile' */
  1116. LVAL xdecompile()
  1117. {
  1118.     LVAL fun,fptr;
  1119.  
  1120.     /* get the closure (or code) and file pointer */
  1121.     fun = xlgetarg();
  1122.     fptr = (moreargs() ? xlgaoport() : curoutput());
  1123.     xllastarg();
  1124.  
  1125.     /* make sure we got either a closure or a code object */
  1126.     if (!closurep(fun) && !methodp(fun))
  1127.     xlbadtype(fun);
  1128.  
  1129.     /* decompile (disassemble) the procedure */
  1130.     decode_procedure(fptr,fun);
  1131.     return (NIL);
  1132. }
  1133.  
  1134. /* xsave - save the memory image */
  1135. LVAL xsave()
  1136. {
  1137.     char *name;
  1138.  
  1139.     /* get the file name, verbose flag and print flag */
  1140.     name = getstring(xlgastring());
  1141.     xllastarg();
  1142.  
  1143.     /* save the memory image */
  1144.     return (xlisave(name) ? true : NIL);
  1145. }
  1146.  
  1147. /* xrestore - restore a saved memory image */
  1148. LVAL xrestore()
  1149. {
  1150.     extern jmp_buf top_level;
  1151.     char *name;
  1152.  
  1153.     /* get the file name, verbose flag and print flag */
  1154.     name = getstring(xlgastring());
  1155.     xllastarg();
  1156.  
  1157.     /* restore the saved memory image */
  1158.     if (!xlirestore(name))
  1159.     return (NIL);
  1160.  
  1161.     /* return directly to the top level */
  1162.     stdputstr("[ returning to the top level ]\n");
  1163.     longjmp(top_level,1);
  1164.     return (NIL); /* never reached */
  1165. }
  1166.  
  1167. /* xgc - function to force garbage collection */
  1168. LVAL xgc()
  1169. {
  1170.     extern FIXTYPE nnodes,nfree,gccalls,total;
  1171.     extern int nscount,vscount;
  1172.     int arg1,arg2;
  1173.     LVAL arg;
  1174.     
  1175.     /* check the argument list and call the garbage collector */
  1176.     if (moreargs()) {
  1177.     arg = xlgafixnum(); arg1 = (int)getfixnum(arg);
  1178.     arg = xlgafixnum(); arg2 = (int)getfixnum(arg);
  1179.     xllastarg();
  1180.     while (--arg1 >= 0) nexpand(NSSIZE);
  1181.     while (--arg2 >= 0) vexpand(VSSIZE);
  1182.     }
  1183.     else
  1184.     gc();
  1185.  
  1186.     /* return (gccalls nnodes nfree nscount vscount total) */
  1187.     xlval = cons(cvfixnum(total),NIL);
  1188.     xlval = cons(cvfixnum((FIXTYPE)vscount),xlval);
  1189.     xlval = cons(cvfixnum((FIXTYPE)nscount),xlval);
  1190.     xlval = cons(cvfixnum(nfree),xlval);
  1191.     xlval = cons(cvfixnum(nnodes),xlval);
  1192.     xlval = cons(cvfixnum(gccalls),xlval);
  1193.     return (xlval);
  1194. }
  1195.  
  1196. /* xerror - built-in function 'error' */
  1197. LVAL xerror()
  1198. {
  1199.     extern jmp_buf top_level;
  1200.     LVAL msg;
  1201.  
  1202.     /* display the error message */
  1203.     msg = xlgastring();
  1204.     errputstr("error: ");
  1205.     errputstr(getstring(msg));
  1206.     errputstr("\n");
  1207.     
  1208.     /* print each of the remaining arguments on separate lines */
  1209.     while (moreargs()) {
  1210.     errputstr("  ");
  1211.     errprint(xlgetarg());
  1212.     }
  1213.     
  1214.     /* print the function where the error occurred */
  1215.     errputstr("happened in: ");
  1216.     errprint(xlfun);
  1217.  
  1218.     /* call the handler */
  1219.     callerrorhandler();
  1220.     return (NIL); /* never reached */
  1221. }
  1222.  
  1223. /* xreset - built-in function 'reset' */
  1224. LVAL xreset()
  1225. {
  1226.     extern jmp_buf top_level;
  1227.     xllastarg();
  1228.     longjmp(top_level,1);
  1229.     return (NIL); /* never reached */
  1230. }
  1231.  
  1232. /* xgetarg - return a command line argument */
  1233. LVAL xgetarg()
  1234. {
  1235.     extern char **clargv;
  1236.     extern int clargc;
  1237.     LVAL arg;
  1238.     int n;
  1239.     arg = xlgafixnum(); n = (int)getfixnum(arg);
  1240.     xllastarg();
  1241.     return (n >= 0 && n < clargc ? cvstring(clargv[n]) : NIL);
  1242. }
  1243.  
  1244. /* xexit - exit to the operating system */
  1245. LVAL xexit()
  1246. {
  1247.     xllastarg();
  1248.     xlwrapup();
  1249.     return (NIL); /* never reached */
  1250. }
  1251.