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