home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / file.d < prev    next >
Encoding:
Text File  |  1994-05-07  |  42.7 KB  |  2,141 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19. */
  20.  
  21. /*
  22.     file.d
  23.     IMPLEMENTATION-DEPENDENT
  24.  
  25.     The specification of printf may be dependent on the C library,
  26.     especially for read-write access, append access, etc.
  27.     The file also contains the code to reclaim the I/O buffer
  28.     by accessing the FILE structure of C.
  29.     It also contains read_fasl_data.
  30. */
  31.  
  32. #define IN_FILE
  33. #include "include.h"
  34.  
  35. #define    kclgetc(FP)        getc(FP)
  36. #define    kclungetc(C, FP)    ungetc(C, FP)
  37. #define    kclfeof(FP)        feof(FP)
  38. #define    kclputc(C, FP)        putc(C, FP)
  39.  
  40. #ifdef HAVE_AOUT
  41. #undef ATT
  42. #undef BSD
  43. #ifndef HAVE_ELF
  44. #define BSD
  45. #endif
  46. #include HAVE_AOUT
  47. #endif
  48.  
  49. #ifdef ATT
  50. #include <filehdr.h>
  51. #include <syms.h>
  52. #endif
  53.  
  54. #ifdef E15
  55. #include <a.out.h>
  56. #define exec    bhdr
  57. #define a_text    tsize
  58. #define a_data    dsize
  59. #define a_bss    bsize
  60. #define a_syms    ssize
  61. #define a_trsize    rtsize
  62. #define a_drsize    rdsize
  63. #endif
  64.  
  65. #ifdef HAVE_ELF
  66. #include <elf.h>
  67. #endif
  68.  
  69. static object terminal_io;
  70.  
  71. object Vverbose;
  72. object LSP_string;
  73.  
  74.  
  75. object siVignore_eof_on_terminal_io;
  76.  
  77. bool
  78. feof1(fp)
  79. FILE *fp;
  80. {
  81.     if (!feof(fp))
  82.         return(FALSE);
  83.     if (fp == terminal_io->sm.sm_object0->sm.sm_fp) {
  84.         if (symbol_value(siVignore_eof_on_terminal_io) == Cnil)
  85.             return(TRUE);
  86. #ifdef UNIX
  87.         fp = freopen("/dev/tty", "r", fp);
  88. #endif
  89. #ifdef AOSVS
  90.  
  91. #endif
  92.         if (fp == NULL)
  93.             error("can't reopen the console");
  94.         return(FALSE);
  95.     }
  96.     return(TRUE);
  97. }
  98.  
  99. #undef    feof
  100. #define    feof    feof1
  101.  
  102.  
  103. end_of_stream(strm)
  104. object strm;
  105. {
  106.     FEerror("Unexpected end of ~S.", 1, strm);
  107. }
  108.  
  109. /*
  110.     Input_stream_p(strm) answers
  111.     if stream strm is an input stream or not.
  112.     It does not check if it really is possible to read
  113.     from the stream,
  114.     but only checks the mode of the stream (sm_mode).
  115. */
  116. bool
  117. input_stream_p(strm)
  118. object strm;
  119. {
  120. BEGIN:
  121.     switch (strm->sm.sm_mode) {
  122.     case smm_input:
  123.         return(TRUE);
  124.  
  125.     case smm_output:
  126.         return(FALSE);
  127.  
  128.     case smm_io:
  129.         return(TRUE);
  130.  
  131.     case smm_probe:
  132.         return(FALSE);
  133.  
  134.     case smm_synonym:
  135.         strm = symbol_value(strm->sm.sm_object0);
  136.         if (type_of(strm) != t_stream)
  137.             FEwrong_type_argument(Sstream, strm);
  138.         goto BEGIN;
  139.  
  140.     case smm_broadcast:
  141.         return(FALSE);
  142.  
  143.     case smm_concatenated:
  144.         return(TRUE);
  145.  
  146.     case smm_two_way:
  147.         return(TRUE);
  148.  
  149.     case smm_echo:
  150.         return(TRUE);
  151.  
  152.     case smm_string_input:
  153.         return(TRUE);
  154.  
  155.     case smm_string_output:
  156.         return(FALSE);
  157.  
  158.     default:
  159.         error("illegal stream mode");
  160.     }
  161. }
  162.  
  163. /*
  164.     Output_stream_p(strm) answers
  165.     if stream strm is an output stream.
  166.     It does not check if it really is possible to write
  167.     to the stream,
  168.     but only checks the mode of the stream (sm_mode).
  169. */
  170. bool
  171. output_stream_p(strm)
  172. object strm;
  173. {
  174. BEGIN:
  175.     switch (strm->sm.sm_mode) {
  176.     case smm_input:
  177.         return(FALSE);
  178.  
  179.     case smm_output:
  180.         return(TRUE);
  181.  
  182.     case smm_io:
  183.         return(TRUE);
  184.  
  185.     case smm_probe:
  186.         return(FALSE);
  187.  
  188.     case smm_synonym:
  189.         strm = symbol_value(strm->sm.sm_object0);
  190.         if (type_of(strm) != t_stream)
  191.             FEwrong_type_argument(Sstream, strm);
  192.         goto BEGIN;
  193.  
  194.     case smm_broadcast:
  195.         return(TRUE);
  196.  
  197.     case smm_concatenated:
  198.         return(FALSE);
  199.  
  200.     case smm_two_way:
  201.         return(TRUE);
  202.  
  203.     case smm_echo:
  204.         return(TRUE);
  205.  
  206.     case smm_string_input:
  207.         return(FALSE);
  208.  
  209.     case smm_string_output:
  210.         return(TRUE);
  211.  
  212.     default:
  213.         error("illegal stream mode");
  214.     }
  215. }
  216.  
  217. object
  218. stream_element_type(strm)
  219. object strm;
  220. {
  221.     object x;
  222.  
  223. BEGIN:
  224.     switch (strm->sm.sm_mode) {
  225.     case smm_input:
  226.     case smm_output:
  227.     case smm_io:
  228.     case smm_probe:
  229.         return(strm->sm.sm_object0);
  230.  
  231.     case smm_synonym:
  232.         strm = symbol_value(strm->sm.sm_object0);
  233.         if (type_of(strm) != t_stream)
  234.             FEwrong_type_argument(Sstream, strm);
  235.         goto BEGIN;
  236.  
  237.     case smm_broadcast:
  238.         x = strm->sm.sm_object0;
  239.         if (endp(x))
  240.             return(Ct);
  241.         return(stream_element_type(x->c.c_car));
  242.  
  243.     case smm_concatenated:
  244.         x = strm->sm.sm_object0;
  245.         if (endp(x))
  246.             return(Ct);
  247.         return(stream_element_type(x->c.c_car));
  248.  
  249.     case smm_two_way:
  250.         return(stream_element_type(strm->sm.sm_object0));
  251.  
  252.     case smm_echo:
  253.         return(stream_element_type(strm->sm.sm_object0));
  254.  
  255.     case smm_string_input:
  256.         return(Sstring_char);
  257.  
  258.     case smm_string_output:
  259.         return(Sstring_char);
  260.  
  261.     default:
  262.         error("illegal stream mode");
  263.     }
  264. }
  265.  
  266. /*
  267.     Open_stream(fn, smm, if_exists, if_does_not_exist)
  268.     opens file fn with mode smm.
  269.     Fn is a namestring.
  270. */
  271. object
  272. open_stream(fn, smm, if_exists, if_does_not_exist)
  273. object fn;
  274. enum smmode smm;
  275. object if_exists, if_does_not_exist;
  276. {
  277.     object x;
  278.     FILE *fp;
  279.     char fname[BUFSIZ];
  280.     int i;
  281.     vs_mark;
  282.  
  283. /*
  284.     if (type_of(fn) != t_string)
  285.         FEwrong_type_argument(Sstring, fn);
  286. */
  287.     if (fn->st.st_fillp > BUFSIZ - 1)
  288.         too_long_file_name(fn);
  289.     for (i = 0;  i < fn->st.st_fillp;  i++)
  290.         fname[i] = fn->st.st_self[i];
  291.     fname[i] = '\0';
  292.     if (smm == smm_input || smm == smm_probe) {
  293.         fp = fopen(fname, "r");
  294.         if (fp == NULL) {
  295.             if (if_does_not_exist == Kerror)
  296.                 cannot_open(fn);
  297.             else if (if_does_not_exist == Kcreate) {
  298.                 fp = fopen(fname, "w");
  299.                 if (fp == NULL)
  300.                     cannot_create(fn);
  301.                 fclose(fp);
  302.                 fp = fopen(fname, "r");
  303.                 if (fp == NULL)
  304.                     cannot_open(fn);
  305.             } else if (if_does_not_exist == Cnil)
  306.                 return(Cnil);
  307.             else
  308.              FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
  309.                  1, if_does_not_exist);
  310.         }
  311.     } else if (smm == smm_output || smm == smm_io) {
  312.         if (if_exists == Knew_version && if_does_not_exist == Kcreate)
  313.             goto CREATE;
  314.         fp = fopen(fname, "r");
  315.         if (fp != NULL) {
  316.             fclose(fp);
  317.             if (if_exists == Kerror)
  318.                 FEerror("The file ~A already exists.", 1, fn);
  319.             else if (if_exists == Krename) {
  320.                 if (smm == smm_output)
  321.                     fp = backup_fopen(fname, "w");
  322.                 else
  323.                     fp = backup_fopen(fname, "w+");
  324.                 if (fp == NULL)
  325.                     cannot_create(fn);
  326.             } else if (if_exists == Krename_and_delete ||
  327.                    if_exists == Knew_version ||
  328.                    if_exists == Ksupersede) {
  329.                 if (smm == smm_output)
  330.                     fp = fopen(fname, "w");
  331.                 else
  332.                     fp = fopen(fname, "w+");
  333.                 if (fp == NULL)
  334.                     cannot_create(fn);
  335.             } else if (if_exists == Koverwrite) {
  336.                 fp = fopen(fname, "r+");
  337.                 if (fp == NULL)
  338.                     cannot_open(fn);
  339.             } else if (if_exists == Kappend) {
  340.                 if (smm == smm_output)
  341.                     fp = fopen(fname, "a");
  342.                 else
  343.                     fp = fopen(fname, "a+");
  344.                 if (fp == NULL)
  345.                 FEerror("Cannot append to the file ~A.",1,fn);
  346.             } else if (if_exists == Cnil)
  347.                 return(Cnil);
  348.             else
  349.                 FEerror("~S is an illegal IF-EXISTS option.",
  350.                     1, if_exists);
  351.         } else {
  352.             if (if_does_not_exist == Kerror)
  353.                 FEerror("The file ~A does not exist.", 1, fn);
  354.             else if (if_does_not_exist == Kcreate) {
  355.             CREATE:
  356.                 if (smm == smm_output)
  357.                     fp = fopen(fname, "w");
  358.                 else
  359.                     fp = fopen(fname, "w+");
  360.                 if (fp == NULL)
  361.                     cannot_create(fn);
  362.             } else if (if_does_not_exist == Cnil)
  363.                 return(Cnil);
  364.             else
  365.              FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
  366.                  1, if_does_not_exist);
  367.         }
  368.     } else
  369.         error("illegal stream mode");
  370.     x = alloc_object(t_stream);
  371.     x->sm.sm_mode = (short)smm;
  372.     x->sm.sm_fp = fp;
  373.  
  374.     x->sm.sm_buffer = 0;
  375.     x->sm.sm_object0 = Sstring_char;
  376.     x->sm.sm_object1 = fn;
  377.     x->sm.sm_int0 = x->sm.sm_int1 = 0;
  378.     vs_push(x);
  379.     {char *buf=alloc_contblock(BUFSIZ);
  380.       x->sm.sm_buffer = buf;
  381. #ifdef SGC
  382.     perm_writable(buf,BUFSIZ);
  383. #endif
  384.     setbuf(fp, buf);
  385.     }    
  386.     vs_reset;
  387.     return(x);
  388. }
  389.  
  390. /*
  391.     Close_stream(strm, abort_flag) closes stream strm.
  392.     The abort_flag is not used now.
  393. */
  394. close_stream(strm, abort_flag)
  395. object strm;
  396. bool abort_flag;    /*  Not used now!  */
  397. {
  398.     object x;
  399.  
  400. BEGIN:
  401.     switch (strm->sm.sm_mode) {
  402.     case smm_output:
  403.         if (strm->sm.sm_fp == stdout)
  404.             FEerror("Cannot close the standard output.", 0);
  405.         if (strm->sm.sm_fp == NULL) break;
  406.         fflush(strm->sm.sm_fp);
  407.         if (strm->sm.sm_buffer)
  408.             {insert_contblock(strm->sm.sm_buffer, BUFSIZ);
  409.                 strm->sm.sm_buffer = 0;}
  410.                   else
  411.                    printf("no buffer? %x  \n",strm->sm.sm_fp);
  412. #ifndef FCLOSE_SETBUF_OK
  413.         strm->sm.sm_fp->_base = NULL;
  414. #endif
  415.  
  416.         fclose(strm->sm.sm_fp);
  417.         strm->sm.sm_fp = NULL;
  418.         break;
  419.  
  420.     case smm_input:
  421.         if (strm->sm.sm_fp == stdin)
  422.             FEerror("Cannot close the standard input.", 0);
  423.  
  424.     case smm_io:
  425.     case smm_probe:
  426.         if (strm->sm.sm_fp == NULL) break;
  427.         if (strm->sm.sm_buffer)
  428.             {insert_contblock(strm->sm.sm_buffer, BUFSIZ);
  429.                 strm->sm.sm_buffer = 0;}
  430.                   else
  431.                    printf("no buffer? %x  \n",strm->sm.sm_fp);
  432.  
  433. #ifndef FCLOSE_SETBUF_OK
  434.         strm->sm.sm_fp->_base = NULL;
  435. #endif
  436.         fclose(strm->sm.sm_fp);
  437.         strm->sm.sm_fp = NULL;
  438.         break;
  439.  
  440.     case smm_synonym:
  441.         strm = symbol_value(strm->sm.sm_object0);
  442.         if (type_of(strm) != t_stream)
  443.             FEwrong_type_argument(Sstream, strm);
  444.         goto BEGIN;
  445.  
  446.     case smm_broadcast:
  447.         for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
  448.             close_stream(x->c.c_car, abort_flag);
  449.         break;
  450.  
  451.     case smm_concatenated:
  452.         for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
  453.             close_stream(x->c.c_car, abort_flag);
  454.         break;
  455.  
  456.     case smm_two_way:
  457.         close_stream(strm->sm.sm_object0);
  458.         close_stream(strm->sm.sm_object1);
  459.         break;
  460.  
  461.     case smm_echo:
  462.         close_stream(strm->sm.sm_object0);
  463.         close_stream(strm->sm.sm_object1);
  464.         break;
  465.  
  466.     case smm_string_input:
  467.         break;        /*  There is nothing to do.  */
  468.  
  469.     case smm_string_output:
  470.         break;        /*  There is nothing to do.  */
  471.  
  472.     default:
  473.         error("illegal stream mode");
  474.     }
  475. }
  476.  
  477. object
  478. make_two_way_stream(istrm, ostrm)
  479. object istrm, ostrm;
  480. {
  481.     object strm;
  482.  
  483.     strm = alloc_object(t_stream);
  484.     strm->sm.sm_mode = (short)smm_two_way;
  485.     strm->sm.sm_fp = NULL;
  486.     strm->sm.sm_object0 = istrm;
  487.     strm->sm.sm_object1 = ostrm;
  488.     strm->sm.sm_int0 = strm->sm.sm_int1 = 0;
  489.     return(strm);
  490. }
  491.  
  492. object
  493. make_echo_stream(istrm, ostrm)
  494. object istrm, ostrm;
  495. {
  496.     object strm;
  497.  
  498.     strm = make_two_way_stream(istrm, ostrm);
  499.     strm->sm.sm_mode = (short)smm_echo;
  500.     return(strm);
  501. }
  502.  
  503. object
  504. make_string_input_stream(strng, istart, iend)
  505. object strng;
  506. int istart, iend;
  507. {
  508.     object strm;
  509.  
  510.     strm = alloc_object(t_stream);
  511.     strm->sm.sm_mode = (short)smm_string_input;
  512.     strm->sm.sm_fp = NULL;
  513.     strm->sm.sm_object0 = strng;
  514.     strm->sm.sm_object1 = OBJNULL;
  515.     strm->sm.sm_int0 = istart;
  516.     strm->sm.sm_int1 = iend;
  517.     return(strm);
  518. }
  519.  
  520. object
  521. make_string_output_stream(line_length)
  522. int line_length;
  523. {
  524.     object strng, strm;
  525.     vs_mark;
  526.  
  527.     strng = alloc_object(t_string);
  528.     strng->st.st_hasfillp = TRUE;
  529.     strng->st.st_adjustable = TRUE;
  530.     strng->st.st_displaced = Cnil;
  531.     strng->st.st_dim = line_length;
  532.     strng->st.st_fillp = 0;
  533.     strng->st.st_self = NULL;
  534.         /*  For GBC not to go mad.  */
  535.     vs_push(strng);
  536.         /*  Saving for GBC.  */
  537.     strng->st.st_self = alloc_relblock(line_length);
  538.     strm = alloc_object(t_stream);
  539.     strm->sm.sm_mode = (short)smm_string_output;
  540.     strm->sm.sm_fp = NULL;
  541.     strm->sm.sm_object0 = strng;
  542.     strm->sm.sm_object1 = OBJNULL;
  543.     strm->sm.sm_int0 = strm->sm.sm_int1 = 0;
  544.     vs_reset;
  545.     return(strm);
  546. }
  547.  
  548. object
  549. get_output_stream_string(strm)
  550. object strm;
  551. {
  552.     object strng;
  553.  
  554.     strng = copy_simple_string(strm->sm.sm_object0);
  555.     strm->sm.sm_object0->st.st_fillp = 0;
  556.     return(strng);
  557. }
  558.  
  559. int
  560. readc_stream(strm)
  561. object strm;
  562. {
  563.     int c;
  564.  
  565. BEGIN:
  566.     switch (strm->sm.sm_mode) {
  567.     case smm_input:
  568.     case smm_io:
  569.         if (strm->sm.sm_fp == NULL)
  570.             closed_stream(strm);
  571.         c = kclgetc(strm->sm.sm_fp);
  572.         c &= 0377;
  573.         if (kclfeof(strm->sm.sm_fp))
  574.             end_of_stream(strm);
  575.         strm->sm.sm_int0++;
  576.         return(c);
  577.  
  578.     case smm_synonym:
  579.         strm = symbol_value(strm->sm.sm_object0);
  580.         if (type_of(strm) != t_stream)
  581.             FEwrong_type_argument(Sstream, strm);
  582.         goto BEGIN;
  583.  
  584.     case smm_concatenated:
  585.     CONCATENATED:
  586.         if (endp(strm->sm.sm_object0)) {
  587.             end_of_stream(strm);
  588.         }
  589.         if (stream_at_end(strm->sm.sm_object0->c.c_car)) {
  590.             strm->sm.sm_object0
  591.             = strm->sm.sm_object0->c.c_cdr;
  592.             goto CONCATENATED;
  593.         }
  594.         c = readc_stream(strm->sm.sm_object0->c.c_car);
  595.         return(c);
  596.  
  597.     case smm_two_way:
  598. #ifdef UNIX
  599.         if (strm == terminal_io)                /**/
  600.             flush_stream(terminal_io->sm.sm_object1);    /**/
  601. #endif
  602.         strm->sm.sm_int1 = 0;
  603.         strm = strm->sm.sm_object0;
  604.         goto BEGIN;
  605.  
  606.     case smm_echo:
  607.         c = readc_stream(strm->sm.sm_object0);
  608.         if (strm->sm.sm_int0 == 0)
  609.             writec_stream(c, strm->sm.sm_object1);
  610.         else
  611.             --(strm->sm.sm_int0);
  612.         return(c);
  613.  
  614.     case smm_string_input:
  615.         if (strm->sm.sm_int0 >= strm->sm.sm_int1)
  616.             end_of_stream(strm);
  617.         return(strm->sm.sm_object0->st.st_self
  618.                [strm->sm.sm_int0++]);
  619.  
  620.     case smm_output:
  621.     case smm_probe:
  622.     case smm_broadcast:
  623.     case smm_string_output:
  624.         cannot_read(strm);
  625. #ifdef USER_DEFINED_STREAMS
  626.     case smm_user_defined:
  627. #define STM_DATA_STRUCT 0
  628. #define STM_READ_CHAR 1
  629. #define STM_WRITE_CHAR 2
  630. #define STM_UNREAD_CHAR 7
  631. #define STM_FORCE_OUTPUT 4
  632. #define STM_PEEK_CHAR 3
  633. #define STM_CLOSE 5
  634. #define STM_TYPE 6
  635. #define STM_NAME 8
  636. {object val;
  637.         object *old_vs_base = vs_base;
  638.         object *old_vs_top = vs_top;
  639.         vs_base = vs_top;
  640.         vs_push(strm);
  641.         super_funcall(strm->sm.sm_object1->str.str_self[STM_READ_CHAR]);
  642.         val = vs_base[0];
  643.         vs_base = old_vs_base;
  644.         vs_top = old_vs_top;
  645.         if (type_of(val) == t_fixnum)
  646.           return (fix(val));
  647.         if (type_of(val) == t_character)
  648.           return (char_code(val));
  649.           }
  650.  
  651. #endif
  652.  
  653.     default:    
  654.         error("illegal stream mode");
  655.     }
  656. }
  657.  
  658. unreadc_stream(c, strm)
  659. int c;
  660. object strm;
  661. {
  662. BEGIN:
  663.     switch (strm->sm.sm_mode) {
  664.     case smm_input:
  665.     case smm_io:
  666.         if (strm->sm.sm_fp == NULL)
  667.             closed_stream(strm);
  668.         kclungetc(c, strm->sm.sm_fp);
  669.         --strm->sm.sm_int0;
  670.         break;
  671.  
  672.     case smm_synonym:
  673.         strm = symbol_value(strm->sm.sm_object0);
  674.         if (type_of(strm) != t_stream)
  675.             FEwrong_type_argument(Sstream, strm);
  676.         goto BEGIN;
  677.  
  678.     case smm_concatenated:
  679.         if (endp(strm->sm.sm_object0))
  680.             goto UNREAD_ERROR;
  681.         strm = strm->sm.sm_object0->c.c_car;
  682.         goto BEGIN;
  683.  
  684.     case smm_two_way:
  685.         strm = strm->sm.sm_object0;
  686.         goto BEGIN;
  687.  
  688.     case smm_echo:
  689.         unreadc_stream(c, strm->sm.sm_object0);
  690.         (strm->sm.sm_int0)++;
  691.         break;
  692.  
  693.     case smm_string_input:
  694.         if (strm->sm.sm_int0 <= 0)
  695.             goto UNREAD_ERROR;
  696.         --strm->sm.sm_int0;
  697.         break;
  698.  
  699.     case smm_output:
  700.     case smm_probe:
  701.     case smm_broadcast:
  702.     case smm_string_output:
  703.         goto UNREAD_ERROR;
  704.  
  705. #ifdef USER_DEFINED_STREAMS
  706.         case smm_user_defined:
  707.         {object *old_vs_base = vs_base;
  708.          object *old_vs_top = vs_top;
  709.          vs_base = vs_top;
  710.          vs_push(strm);
  711.          /* if there is a file pointer and no define unget function,
  712.                   * then call ungetc */
  713.          if ((strm->sm.sm_fp != NULL ) &&
  714.              strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR] == Cnil)
  715.            kclungetc(c, strm->sm.sm_fp);
  716.          else
  717.            super_funcall(strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR]);
  718.          vs_top = old_vs_top;
  719.          vs_base = old_vs_base;
  720.            }
  721.         break;
  722. #endif
  723.     default:
  724.         error("illegal stream mode");
  725.     }
  726.     return;
  727.  
  728. UNREAD_ERROR:
  729.     FEerror("Cannot unread the stream ~S.", 1, strm);
  730. }
  731.  
  732. writec_stream(c, strm)
  733. int c;
  734. object strm;
  735. {
  736.     object x;
  737.     char *p;
  738.     int i;
  739.  
  740. BEGIN:
  741.     switch (strm->sm.sm_mode) {
  742.     case smm_output:
  743.     case smm_io:
  744.         strm->sm.sm_int0++;
  745.         if (c == '\n')
  746.             strm->sm.sm_int1 = 0;
  747.         else if (c == '\t')
  748.             strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8;
  749.         else
  750.             strm->sm.sm_int1++;
  751.         if (strm->sm.sm_fp == NULL)
  752.             closed_stream(strm);
  753.         kclputc(c, strm->sm.sm_fp);
  754.         break;
  755.  
  756.     case smm_synonym:
  757.         strm = symbol_value(strm->sm.sm_object0);
  758.         if (type_of(strm) != t_stream)
  759.             FEwrong_type_argument(Sstream, strm);
  760.         goto BEGIN;
  761.  
  762.     case smm_broadcast:
  763.         for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
  764.             writec_stream(c, x->c.c_car);
  765.         break;
  766.  
  767.     case smm_two_way:
  768.         strm->sm.sm_int0++;
  769.         if (c == '\n')
  770.             strm->sm.sm_int1 = 0;
  771.         else if (c == '\t')
  772.             strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8;
  773.         else
  774.             strm->sm.sm_int1++;
  775.         strm = strm->sm.sm_object1;
  776.         goto BEGIN;
  777.  
  778.     case smm_echo:
  779.         strm = strm->sm.sm_object1;
  780.         goto BEGIN;
  781.  
  782.     case smm_string_output:
  783.         strm->sm.sm_int0++;
  784.         if (c == '\n')
  785.             strm->sm.sm_int1 = 0;
  786.         else if (c == '\t')
  787.             strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8;
  788.         else
  789.             strm->sm.sm_int1++;
  790.         x = strm->sm.sm_object0;
  791.         if (x->st.st_fillp >= x->st.st_dim) {
  792.             if (!x->st.st_adjustable)
  793.                 FEerror("The string ~S is not adjustable.",
  794.                     1, x);
  795.             p = alloc_relblock(x->st.st_dim * 2 + 16);
  796.             for (i = 0;  i < x->st.st_dim;  i++)
  797.                 p[i] = x->st.st_self[i];
  798.             i = x->st.st_dim * 2 + 16;
  799. #define    ADIMLIM        16*1024*1024
  800.             if (i >= ADIMLIM)
  801.                 FEerror("Can't extend the string.", 0);
  802.             x->st.st_dim = i;
  803.             adjust_displaced(x, p - x->st.st_self);
  804.         }
  805.         x->st.st_self[x->st.st_fillp++] = c;
  806.         break;
  807.  
  808.     case smm_input:
  809.     case smm_probe:
  810.     case smm_concatenated:
  811.     case smm_string_input:
  812.         cannot_write(strm);
  813.  
  814. #ifdef USER_DEFINED_STREAMS
  815.     case smm_user_defined:
  816.         {object *old_vs_base = vs_base;
  817.          object *old_vs_top = vs_top;
  818.          vs_base = vs_top;
  819.          vs_push(strm);
  820.          vs_push(code_char(c));
  821.          super_funcall(strm->sm.sm_object1->str.str_self[2]);
  822.          vs_base = old_vs_base;
  823.          vs_top = old_vs_top;
  824.          break;
  825.            }
  826.  
  827. #endif
  828.     default:
  829.         error("illegal stream mode");
  830.     }
  831.     return(c);
  832. }
  833.  
  834. writestr_stream(s, strm)
  835. char *s;
  836. object strm;
  837. {
  838.     while (*s != '\0')
  839.         writec_stream(*s++, strm);
  840. }
  841.  
  842. flush_stream(strm)
  843. object strm;
  844. {
  845.     object x;
  846.  
  847. BEGIN:
  848.     switch (strm->sm.sm_mode) {
  849.     case smm_output:
  850.     case smm_io:
  851.         if (strm->sm.sm_fp == NULL)
  852.             closed_stream(strm);
  853.         fflush(strm->sm.sm_fp);
  854.         break;
  855.  
  856.     case smm_synonym:
  857.         strm = symbol_value(strm->sm.sm_object0);
  858.         if (type_of(strm) != t_stream)
  859.             FEwrong_type_argument(Sstream, strm);
  860.         goto BEGIN;
  861.  
  862.     case smm_broadcast:
  863.         for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
  864.             flush_stream(x->c.c_car);
  865.         break;
  866.  
  867.     case smm_two_way:
  868.         strm = strm->sm.sm_object1;
  869.         goto BEGIN;
  870.  
  871.     case smm_echo:
  872.         strm = strm->sm.sm_object1;
  873.         goto BEGIN;
  874.  
  875.     case smm_string_output:
  876.         break;
  877.  
  878.     case smm_input:
  879.     case smm_probe:
  880.     case smm_concatenated:
  881.     case smm_string_input:
  882.         FEerror("Cannot flush the stream ~S.", 1, strm);
  883. #ifdef USER_DEFINED_STREAMS
  884.         case smm_user_defined:
  885.         {object *old_vs_base = vs_base;
  886.          object *old_vs_top = vs_top;
  887.          vs_base = vs_top;
  888.          vs_push(strm);
  889.          super_funcall(strm->sm.sm_object1->str.str_self[4]);
  890.          vs_base = old_vs_base;
  891.          vs_top = old_vs_top;
  892.         break;
  893.            }
  894.  
  895. #endif
  896.  
  897.     default:
  898.         error("illegal stream mode");
  899.     }
  900. }
  901.  
  902. bool
  903. stream_at_end(strm)
  904. object strm;
  905. {
  906.     object x;
  907.     int c;
  908.  
  909. BEGIN:
  910.     switch (strm->sm.sm_mode) {
  911.     case smm_io:    
  912.     case smm_input:
  913.         if (strm->sm.sm_fp == NULL)
  914.             closed_stream(strm);
  915.         c = kclgetc(strm->sm.sm_fp);
  916.         if (kclfeof(strm->sm.sm_fp))
  917.             return(TRUE);
  918.         else {
  919.             kclungetc(c, strm->sm.sm_fp);
  920.             return(FALSE);
  921.         }
  922.  
  923.     case smm_output:
  924.         return(FALSE);
  925.  
  926. /*    case smm_io:
  927.         return(FALSE);
  928. */
  929.  
  930.     case smm_probe:
  931.         return(FALSE);
  932.  
  933.     case smm_synonym:
  934.         strm = symbol_value(strm->sm.sm_object0);
  935.         if (type_of(strm) != t_stream)
  936.             FEwrong_type_argument(Sstream, strm);
  937.         goto BEGIN;
  938.  
  939.     case smm_broadcast:
  940.         return(FALSE);
  941.  
  942.     case smm_concatenated:
  943.     CONCATENATED:
  944.         if (endp(strm->sm.sm_object0))
  945.             return(TRUE);
  946.         if (stream_at_end(strm->sm.sm_object0->c.c_car)) {
  947.             strm->sm.sm_object0
  948.             = strm->sm.sm_object0->c.c_cdr;
  949.             goto CONCATENATED;
  950.         } else
  951.             return(FALSE);
  952.  
  953.     case smm_two_way:
  954. #ifdef UNIX
  955.         if (strm == terminal_io)                /**/
  956.             flush_stream(terminal_io->sm.sm_object1);    /**/
  957. #endif
  958.         strm = strm->sm.sm_object0;
  959.         goto BEGIN;
  960.  
  961.     case smm_echo:
  962.         strm = strm->sm.sm_object0;
  963.         goto BEGIN;
  964.  
  965.     case smm_string_input:
  966.         if (strm->sm.sm_int0 >= strm->sm.sm_int1)
  967.             return(TRUE);
  968.         else
  969.             return(FALSE);
  970.  
  971.     case smm_string_output:
  972.         return(FALSE);
  973.  
  974. #ifdef USER_DEFINED_STREAMS
  975.         case smm_user_defined:
  976.           return(FALSE);
  977. #endif
  978.     default:
  979.         error("illegal stream mode");
  980.     }
  981. }
  982.  
  983. #ifdef HAVE_IOCTL
  984. #include <sys/ioctl.h>
  985. #endif
  986.  
  987. bool
  988. listen_stream(strm)
  989. object strm;
  990. {
  991.     object x;
  992.     int c;
  993.  
  994. BEGIN:
  995.     switch (strm->sm.sm_mode) {
  996.     case smm_input:
  997.     case smm_io:
  998.  
  999.         if (strm->sm.sm_fp == NULL)
  1000.             closed_stream(strm);
  1001.         if (feof(strm->sm.sm_fp))
  1002.                 return(FALSE);
  1003. #ifdef LISTEN_FOR_INPUT
  1004.         LISTEN_FOR_INPUT(strm->sm.sm_fp);
  1005. #endif
  1006.         return TRUE;
  1007.  
  1008.     case smm_synonym:
  1009.         strm = symbol_value(strm->sm.sm_object0);
  1010.         if (type_of(strm) != t_stream)
  1011.             FEwrong_type_argument(Sstream, strm);
  1012.         goto BEGIN;
  1013.  
  1014.     case smm_concatenated:
  1015.     CONCATENATED:
  1016.         if (endp(strm->sm.sm_object0))
  1017.             return(FALSE);
  1018.         strm = strm->sm.sm_object0->c.c_car;    /* Incomplete! */
  1019.         goto BEGIN;
  1020.  
  1021.     case smm_two_way:
  1022.     case smm_echo:
  1023.         strm = strm->sm.sm_object0;
  1024.         goto BEGIN;
  1025.  
  1026.     case smm_string_input:
  1027.         if (strm->sm.sm_int0 < strm->sm.sm_int1)
  1028.             return(TRUE);
  1029.         else
  1030.             return(FALSE);
  1031.  
  1032.     case smm_output:
  1033.     case smm_probe:
  1034.     case smm_broadcast:
  1035.     case smm_string_output:
  1036.         FEerror("Can't listen to ~S.", 1, strm);
  1037.  
  1038.     default:
  1039.         error("illegal stream mode");
  1040.     }
  1041. }
  1042.  
  1043. int
  1044. file_position(strm)
  1045. object strm;
  1046. {
  1047. BEGIN:
  1048.     switch (strm->sm.sm_mode) {
  1049.     case smm_input:
  1050.     case smm_output:
  1051.     case smm_io:
  1052.         /*  return(strm->sm.sm_int0);  */
  1053.         if (strm->sm.sm_fp == NULL)
  1054.             closed_stream(strm);
  1055.         return(ftell(strm->sm.sm_fp));
  1056.  
  1057.     case smm_string_output:
  1058.         return(strm->sm.sm_object0->st.st_fillp);
  1059.  
  1060.     case smm_synonym:
  1061.         strm = symbol_value(strm->sm.sm_object0);
  1062.         if (type_of(strm) != t_stream)
  1063.             FEwrong_type_argument(Sstream, strm);
  1064.         goto BEGIN;
  1065.  
  1066.     case smm_probe:
  1067.     case smm_broadcast:
  1068.     case smm_concatenated:
  1069.     case smm_two_way:
  1070.     case smm_echo:
  1071.     case smm_string_input:
  1072.         return(-1);
  1073.  
  1074.     default:
  1075.         error("illegal stream mode");
  1076.     }
  1077. }
  1078.  
  1079. int
  1080. file_position_set(strm, disp)
  1081. object strm;
  1082. int disp;
  1083. {
  1084. BEGIN:
  1085.     switch (strm->sm.sm_mode) {
  1086.     case smm_input:
  1087.     case smm_output:
  1088.     case smm_io:
  1089.         if (strm->sm.sm_fp == NULL)
  1090.             closed_stream(strm);
  1091.         if (fseek(strm->sm.sm_fp, disp, 0) < 0)
  1092.             return(-1);
  1093.         strm->sm.sm_int0 = disp;
  1094.         return(0);
  1095.  
  1096.     case smm_string_output:
  1097.         if (disp < strm->sm.sm_object0->st.st_fillp) {
  1098.             strm->sm.sm_object0->st.st_fillp = disp;
  1099.             strm->sm.sm_int0 = disp;
  1100.         } else {
  1101.             disp -= strm->sm.sm_object0->st.st_fillp;
  1102.             while (disp-- > 0)
  1103.                 writec_stream(' ', strm);
  1104.         }
  1105.         return(0);
  1106.  
  1107.     case smm_synonym:
  1108.         strm = symbol_value(strm->sm.sm_object0);
  1109.         if (type_of(strm) != t_stream)
  1110.             FEwrong_type_argument(Sstream, strm);
  1111.         goto BEGIN;
  1112.  
  1113.     case smm_probe:
  1114.     case smm_broadcast:
  1115.     case smm_concatenated:
  1116.     case smm_two_way:
  1117.     case smm_echo:
  1118.     case smm_string_input:
  1119.         return(-1);
  1120.  
  1121.     default:
  1122.         error("illegal stream mode");
  1123.     }
  1124. }
  1125.  
  1126. int
  1127. file_length(strm)
  1128. object strm;
  1129. {
  1130. BEGIN:
  1131.     switch (strm->sm.sm_mode) {
  1132.     case smm_input:
  1133.     case smm_output:
  1134.     case smm_io:
  1135.         if (strm->sm.sm_fp == NULL)
  1136.             closed_stream(strm);
  1137.         return(file_len(strm->sm.sm_fp));
  1138.  
  1139.     case smm_synonym:
  1140.         strm = symbol_value(strm->sm.sm_object0);
  1141.         if (type_of(strm) != t_stream)
  1142.             FEwrong_type_argument(Sstream, strm);
  1143.         goto BEGIN;
  1144.  
  1145.     case smm_probe:
  1146.     case smm_broadcast:
  1147.     case smm_concatenated:
  1148.     case smm_two_way:
  1149.     case smm_echo:
  1150.     case smm_string_input:
  1151.     case smm_string_output:
  1152.         return(-1);
  1153.  
  1154.     default:
  1155.         error("illegal stream mode");
  1156.     }
  1157. }
  1158.  
  1159. int
  1160. file_column(strm)
  1161. object strm;
  1162. {
  1163.     int i;
  1164.     object x;
  1165.  
  1166. BEGIN:
  1167.     switch (strm->sm.sm_mode) {
  1168.     case smm_output:
  1169.     case smm_io:
  1170.     case smm_two_way:
  1171.     case smm_string_output:
  1172.         return(strm->sm.sm_int1);
  1173.  
  1174.     case smm_synonym:
  1175.         strm = symbol_value(strm->sm.sm_object0);
  1176.         if (type_of(strm) != t_stream)
  1177.             FEwrong_type_argument(Sstream, strm);
  1178.         goto BEGIN;
  1179.  
  1180.     case smm_echo:
  1181.         strm = strm->sm.sm_object1;
  1182.         goto BEGIN;
  1183.  
  1184.     case smm_input:
  1185.     case smm_probe:
  1186.     case smm_string_input:
  1187.         return(-1);
  1188.  
  1189.     case smm_concatenated:
  1190.         if (endp(strm->sm.sm_object0))
  1191.             return(-1);
  1192.         strm = strm->sm.sm_object0->c.c_car;
  1193.         goto BEGIN;
  1194.  
  1195.     case smm_broadcast:
  1196.         for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) {
  1197.             i = file_column(x->c.c_car);
  1198.             if (i >= 0)
  1199.                 return(i);
  1200.         }
  1201.         return(-1);
  1202.  
  1203. #ifdef USER_DEFINED_STREAMS
  1204.     case smm_user_defined: /* not right but what is? */
  1205.         return(-1);
  1206.     
  1207. #endif
  1208.     default:
  1209.         error("illegal stream mode");
  1210.     }
  1211. }
  1212.  
  1213. load(s)
  1214. char *s;
  1215. {
  1216.     object filename, strm, x;
  1217.     vs_mark;
  1218.  
  1219.     filename = make_simple_string(s);
  1220.     vs_push(filename);
  1221.     strm = open_stream(filename, smm_input, Cnil, Kerror);
  1222.     vs_push(strm);
  1223.     for (;;) {
  1224.         preserving_whitespace_flag = FALSE;
  1225.         detect_eos_flag = TRUE;
  1226.         x = read_object_non_recursive(strm);
  1227.         if (x == OBJNULL)
  1228.             break;
  1229.         vs_push(x);
  1230.         ieval(x);
  1231.         vs_pop;
  1232.     }
  1233.     close_stream(strm);
  1234.     vs_reset;
  1235. }
  1236.  
  1237. Lmake_synonym_stream()
  1238. {
  1239.     object x;
  1240.  
  1241.     check_arg(1);
  1242.     check_type_symbol(&vs_base[0]);
  1243.     x = alloc_object(t_stream);
  1244.     x->sm.sm_mode = (short)smm_synonym;
  1245.     x->sm.sm_fp = NULL;
  1246.     x->sm.sm_object0 = vs_base[0];
  1247.     x->sm.sm_object1 = OBJNULL;
  1248.     x->sm.sm_int0 = x->sm.sm_int1 = 0;
  1249.     vs_base[0] = x;
  1250. }
  1251.  
  1252. Lmake_broadcast_stream()
  1253. {
  1254.     object x;
  1255.     int narg, i;
  1256.  
  1257.     narg = vs_top - vs_base;
  1258.     for (i = 0;  i < narg;  i++)
  1259.         if (type_of(vs_base[i]) != t_stream ||
  1260.             !output_stream_p(vs_base[i]))
  1261.             cannot_write(vs_base[i]);
  1262.     vs_push(Cnil);
  1263.     for (i = narg;  i > 0;  --i)
  1264.         stack_cons();
  1265.     x = alloc_object(t_stream);
  1266.     x->sm.sm_mode = (short)smm_broadcast;
  1267.     x->sm.sm_fp = NULL;
  1268.     x->sm.sm_object0 = vs_base[0];
  1269.     x->sm.sm_object1 = OBJNULL;
  1270.     x->sm.sm_int0 = x->sm.sm_int1 = 0;
  1271.     vs_base[0] = x;
  1272. }
  1273.  
  1274. Lmake_concatenated_stream()
  1275. {
  1276.     object x;
  1277.     int narg, i;
  1278.  
  1279.     narg = vs_top - vs_base;
  1280.     for (i = 0;  i < narg;  i++)
  1281.         if (type_of(vs_base[i]) != t_stream ||
  1282.             !input_stream_p(vs_base[i]))
  1283.             cannot_read(vs_base[i]);
  1284.     vs_push(Cnil);
  1285.     for (i = narg;  i > 0;  --i)
  1286.         stack_cons();
  1287.     x = alloc_object(t_stream);
  1288.     x->sm.sm_mode = (short)smm_concatenated;
  1289.     x->sm.sm_fp = NULL;
  1290.     x->sm.sm_object0 = vs_base[0];
  1291.     x->sm.sm_object1 = OBJNULL;
  1292.     x->sm.sm_int0 = x->sm.sm_int1 = 0;
  1293.     vs_base[0] = x;
  1294. }
  1295.  
  1296. Lmake_two_way_stream()
  1297. {
  1298.     check_arg(2);
  1299.  
  1300.     if (type_of(vs_base[0]) != t_stream ||
  1301.         !input_stream_p(vs_base[0]))
  1302.         cannot_read(vs_base[0]);
  1303.     if (type_of(vs_base[1]) != t_stream ||
  1304.         !output_stream_p(vs_base[1]))
  1305.         cannot_write(vs_base[1]);
  1306.     vs_base[0] = make_two_way_stream(vs_base[0], vs_base[1]);
  1307.     vs_pop;
  1308. }
  1309.  
  1310. Lmake_echo_stream()
  1311. {
  1312.     check_arg(2);
  1313.  
  1314.     if (type_of(vs_base[0]) != t_stream ||
  1315.         !input_stream_p(vs_base[0]))
  1316.         cannot_read(vs_base[0]);
  1317.     if (type_of(vs_base[1]) != t_stream ||
  1318.         !output_stream_p(vs_base[1]))
  1319.         cannot_write(vs_base[1]);
  1320.     vs_base[0] = make_echo_stream(vs_base[0], vs_base[1]);
  1321.     vs_pop;
  1322. }
  1323.  
  1324. @(defun make_string_input_stream (strng &o istart iend)
  1325.     int s, e;
  1326. @
  1327.     check_type_string(&strng);
  1328.     if (istart == Cnil)
  1329.         s = 0;
  1330.     else if (type_of(istart) != t_fixnum)
  1331.         goto E;
  1332.     else
  1333.         s = fix(istart);
  1334.     if (iend == Cnil)
  1335.         e = strng->st.st_fillp;
  1336.     else if (type_of(iend) != t_fixnum)
  1337.         goto E;
  1338.     else
  1339.         e = fix(iend);
  1340.     if (s < 0 || e > strng->st.st_fillp || s > e)
  1341.         goto E;
  1342.     @(return `make_string_input_stream(strng, s, e)`)
  1343.  
  1344. E:
  1345.     FEerror("~S and ~S are illegal as :START and :END~%\
  1346. for the string ~S.",
  1347.         3, istart, iend, strng);
  1348. @)
  1349.  
  1350. Lmake_string_output_stream()
  1351. {
  1352.     check_arg(0);
  1353.     vs_push(make_string_output_stream(64));
  1354. }
  1355.  
  1356. Lget_output_stream_string()
  1357. {
  1358.     check_arg(1);
  1359.  
  1360.     if (type_of(vs_base[0]) != t_stream ||
  1361.         (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output)
  1362.         FEerror("~S is not a string-output stream.", 1, vs_base[0]);
  1363.     vs_base[0] = get_output_stream_string(vs_base[0]);
  1364. }
  1365.  
  1366. /*
  1367.     (SI:OUTPUT-STREAM-STRING string-output-stream)
  1368.  
  1369.         extracts the string associated with the given
  1370.         string-output-stream.
  1371. */
  1372. siLoutput_stream_string()
  1373. {
  1374.     check_arg(1);
  1375.     if (type_of(vs_base[0]) != t_stream ||
  1376.         (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output)
  1377.         FEerror("~S is not a string-output stream.", 1, vs_base[0]);
  1378.     vs_base[0] = vs_base[0]->sm.sm_object0;
  1379. }
  1380.  
  1381. Lstreamp()
  1382. {
  1383.     check_arg(1);
  1384.  
  1385.     if (type_of(vs_base[0]) == t_stream)
  1386.         vs_base[0] = Ct;
  1387.     else
  1388.         vs_base[0] = Cnil;
  1389. }
  1390.  
  1391. Linput_stream_p()
  1392. {
  1393.     check_arg(1);
  1394.  
  1395.     check_type_stream(&vs_base[0]);
  1396.     if (input_stream_p(vs_base[0]))
  1397.         vs_base[0] = Ct;
  1398.     else
  1399.         vs_base[0] = Cnil;
  1400. }
  1401.  
  1402. Loutput_stream_p()
  1403. {
  1404.     check_arg(1);
  1405.  
  1406.     check_type_stream(&vs_base[0]);
  1407.     if (output_stream_p(vs_base[0]))
  1408.         vs_base[0] = Ct;
  1409.     else
  1410.         vs_base[0] = Cnil;
  1411. }
  1412.  
  1413. Lstream_element_type()
  1414. {
  1415.     check_arg(1);
  1416.  
  1417.     check_type_stream(&vs_base[0]);
  1418.     vs_base[0] = stream_element_type(vs_base[0]);
  1419. }
  1420.  
  1421. @(defun close (strm &key abort)
  1422. @
  1423.     check_type_stream(&strm);
  1424.     close_stream(strm, abort != Cnil);
  1425.     @(return Ct)
  1426. @)
  1427.  
  1428. @(defun open (filename
  1429.           &key (direction Kinput)
  1430.            (element_type Sstring_char)
  1431.            (if_exists Cnil iesp)
  1432.            (if_does_not_exist Cnil idnesp)
  1433.           &aux strm)
  1434.     enum smmode smm;
  1435. @
  1436.     check_type_or_pathname_string_symbol_stream(&filename);
  1437.     filename = coerce_to_namestring(filename);
  1438.     if (direction == Kinput) {
  1439.         smm = smm_input;
  1440.         if (!idnesp)
  1441.             if_does_not_exist = Kerror;
  1442.     } else if (direction == Koutput) {
  1443.         smm = smm_output;
  1444.         if (!iesp)
  1445.             if_exists = Knew_version;
  1446.         if (!idnesp) {
  1447.             if (if_exists == Koverwrite ||
  1448.                 if_exists == Kappend)
  1449.                 if_does_not_exist = Kerror;
  1450.             else
  1451.                 if_does_not_exist = Kcreate;
  1452.         }
  1453.     } else if (direction == Kio) {
  1454.         smm = smm_io;
  1455.         if (!iesp)
  1456.             if_exists = Knew_version;
  1457.         if (!idnesp) {
  1458.             if (if_exists == Koverwrite ||
  1459.                 if_exists == Kappend)
  1460.                 if_does_not_exist = Kerror;
  1461.             else
  1462.                 if_does_not_exist = Kcreate;
  1463.         }
  1464.     } else if (direction == Kprobe) {
  1465.         smm = smm_probe;
  1466.         if (!idnesp)
  1467.             if_does_not_exist = Cnil;
  1468.     } else
  1469.         FEerror("~S is an illegal DIRECTION for OPEN.",
  1470.             1, direction);
  1471.     strm = open_stream(filename, smm, if_exists, if_does_not_exist);
  1472.     @(return strm)
  1473. @)
  1474.  
  1475. @(defun file_position (file_stream &o position)
  1476.     int i;
  1477. @
  1478.     check_type_stream(&file_stream);
  1479.     if (position == Cnil) {
  1480.         i = file_position(file_stream);
  1481.         if (i < 0)
  1482.             @(return Cnil)
  1483.         @(return `make_fixnum(i)`)
  1484.     } else {
  1485.         if (position == Kstart)
  1486.             i = 0;
  1487.         else if (position == Kend)
  1488.             i = file_length(file_stream);
  1489.         else if (type_of(position) != t_fixnum ||
  1490.             (i = fix((position))) < 0)
  1491.             FEerror("~S is an illegal file position~%\
  1492. for the file-stream ~S.",
  1493.                 2, position, file_stream);
  1494.         if (file_position_set(file_stream, i) < 0)
  1495.             @(return Cnil)
  1496.         @(return Ct)
  1497.     }    
  1498. @)
  1499.  
  1500. Lfile_length()
  1501. {
  1502.     int i;
  1503.  
  1504.     check_arg(1);
  1505.     check_type_stream(&vs_base[0]);
  1506.     i = file_length(vs_base[0]);
  1507.     if (i < 0)
  1508.         vs_base[0] = Cnil;
  1509.     else
  1510.         vs_base[0] = make_fixnum(i);
  1511. }
  1512.  
  1513. object siVload_pathname;
  1514.  
  1515. @(defun load (pathname
  1516.           &key (verbose `symbol_value(Vload_verbose)`)
  1517.             print
  1518.             (if_does_not_exist Kerror)
  1519.           &aux pntype fasl_filename lsp_filename filename
  1520.            defaults strm stdoutput x
  1521.            package)
  1522.     bds_ptr old_bds_top;
  1523.     int i;
  1524.     object strm1;
  1525. @
  1526.     check_type_or_pathname_string_symbol_stream(&pathname);
  1527.     pathname = coerce_to_pathname(pathname);
  1528.     defaults = symbol_value(Vdefault_pathname_defaults);
  1529.     defaults = coerce_to_pathname(defaults);
  1530.     pathname = merge_pathnames(pathname, defaults, Knewest);
  1531.     pntype = pathname->pn.pn_type;
  1532.     filename = coerce_to_namestring(pathname);
  1533.         old_bds_top=bds_top;
  1534.       if (pntype == Cnil || pntype == Kwild ||
  1535.         type_of(pntype) == t_string &&
  1536. #ifdef UNIX
  1537.         string_eq(pntype, FASL_string)) {
  1538. #endif
  1539. #ifdef AOSVS
  1540.  
  1541. #endif
  1542.         pathname->pn.pn_type = FASL_string;
  1543.         fasl_filename = coerce_to_namestring(pathname);
  1544.     }
  1545.     if (pntype == Cnil || pntype == Kwild ||
  1546.         type_of(pntype) == t_string &&
  1547. #ifdef UNIX
  1548.         string_eq(pntype, LSP_string)) {
  1549. #endif
  1550. #ifdef AOSVS
  1551.  
  1552. #endif
  1553.         pathname->pn.pn_type = LSP_string;
  1554.         lsp_filename = coerce_to_namestring(pathname);
  1555.     }
  1556.     if (fasl_filename != Cnil && file_exists(fasl_filename)) {
  1557.         if (verbose != Cnil) {
  1558.             setupPRINTdefault(fasl_filename);
  1559.             if (file_column(PRINTstream) != 0)
  1560.                 write_str("\n");
  1561.             write_str("Loading ");
  1562.             PRINTescape = FALSE;
  1563.             write_object(fasl_filename, 0);
  1564.             write_str("\n");
  1565.             cleanupPRINT();
  1566.             flush_stream(PRINTstream);
  1567.         }
  1568.         package = symbol_value(Vpackage);
  1569.         bds_bind(Vpackage, package);
  1570.         bds_bind(siVload_pathname,fasl_filename);
  1571.         i = fasload(fasl_filename);
  1572.         if (print != Cnil) {
  1573.             setupPRINTdefault(Cnil);
  1574.             vs_top = PRINTvs_top;
  1575.             if (file_column(PRINTstream) != 0)
  1576.                 write_str("\n");
  1577.             write_str("Fasload successfully ended.");
  1578.             write_str("\n");
  1579.             cleanupPRINT();
  1580.             flush_stream(PRINTstream);
  1581.         }
  1582.         bds_unwind(old_bds_top);
  1583.         if (verbose != Cnil) {
  1584.             setupPRINTdefault(fasl_filename);
  1585.             if (file_column(PRINTstream) != 0)
  1586.                 write_str("\n");
  1587.             write_str("Finished loading ");
  1588.             PRINTescape = FALSE;
  1589.             write_object(fasl_filename, 0);
  1590.             write_str("\n");
  1591.             cleanupPRINT();
  1592.             flush_stream(PRINTstream);
  1593.         }
  1594.         @(return `make_fixnum(i)`)
  1595.     }
  1596.     if (lsp_filename != Cnil && file_exists(lsp_filename)) {
  1597.         filename = lsp_filename;
  1598.     }
  1599.     if (if_does_not_exist != Cnil)
  1600.         if_does_not_exist = Kerror;
  1601.     strm1 = strm
  1602.     = open_stream(filename, smm_input, Cnil, if_does_not_exist);
  1603.     if (strm == Cnil)
  1604.         @(return Cnil)
  1605.     if (verbose != Cnil) {
  1606.         setupPRINTdefault(filename);
  1607.         if (file_column(PRINTstream) != 0)
  1608.             write_str("\n");
  1609.         write_str("Loading ");
  1610.         PRINTescape = FALSE;
  1611.         write_object(filename, 0);
  1612.         write_str("\n");
  1613.         cleanupPRINT();
  1614.         flush_stream(PRINTstream);
  1615.     }
  1616.     package = symbol_value(Vpackage);
  1617.     bds_bind(siVload_pathname,pathname);
  1618.     bds_bind(Vpackage, package);
  1619.     bds_bind(Vstandard_input, strm);
  1620.     frs_push(FRS_PROTECT, Cnil);
  1621.     if (nlj_active) {
  1622.         close_stream(strm1, TRUE);
  1623.         nlj_active = FALSE;
  1624.         frs_pop();
  1625.         bds_unwind(old_bds_top);
  1626.         unwind(nlj_fr, nlj_tag);
  1627.     }
  1628.     for (;;) {
  1629.         preserving_whitespace_flag = FALSE;
  1630.         detect_eos_flag = TRUE;
  1631.         x = read_object_non_recursive(strm);
  1632.         if (x == OBJNULL)
  1633.             break;
  1634.         {
  1635.             object *base = vs_base, *top = vs_top, *lex = lex_env;
  1636.             object xx;
  1637.  
  1638.             lex_new();
  1639.             eval(x);
  1640.             xx = vs_base[0];
  1641.             lex_env = lex;
  1642.             vs_top = top;
  1643.             vs_base = base;
  1644.             x = xx;
  1645.         }
  1646.         if (print != Cnil) {
  1647.             setupPRINTdefault(x);
  1648.             write_object(x, 0);
  1649.             write_str("\n");
  1650.             cleanupPRINT();
  1651.             flush_stream(PRINTstream);
  1652.         }
  1653.     }
  1654.     close_stream(strm, TRUE);
  1655.     frs_pop();
  1656.     bds_unwind(old_bds_top);
  1657.     if (verbose != Cnil) {
  1658.         setupPRINTdefault(filename);
  1659.         if (file_column(PRINTstream) != 0)
  1660.             write_str("\n");
  1661.         write_str("Finished loading ");
  1662.         PRINTescape = FALSE;
  1663.         write_object(filename, 0);
  1664.         write_str("\n");
  1665.         cleanupPRINT();
  1666.         flush_stream(PRINTstream);
  1667.     }
  1668.     @(return Ct)
  1669. @)
  1670.  
  1671. siLget_string_input_stream_index()
  1672. {
  1673.     check_arg(1);
  1674.     check_type_stream(&vs_base[0]);
  1675.     if ((enum smmode)vs_base[0]->sm.sm_mode != smm_string_input)
  1676.         FEerror("~S is not a string-input stream.", 1, vs_base[0]);
  1677.     vs_base[0] = make_fixnum(vs_base[0]->sm.sm_int0);
  1678. }
  1679.  
  1680. siLmake_string_output_stream_from_string()
  1681. {
  1682.     object strng, strm;
  1683.  
  1684.     check_arg(1);
  1685.     strng = vs_base[0];
  1686.     if (type_of(strng) != t_string || !strng->st.st_hasfillp)
  1687.         FEerror("~S is not a string with a fill-pointer.", 1, strng);
  1688.     strm = alloc_object(t_stream);
  1689.     strm->sm.sm_mode = (short)smm_string_output;
  1690.     strm->sm.sm_fp = NULL;
  1691.     strm->sm.sm_object0 = strng;
  1692.     strm->sm.sm_object1 = OBJNULL;
  1693.     strm->sm.sm_int0 = strng->st.st_fillp;
  1694.     strm->sm.sm_int1 = 0;
  1695.     vs_base[0] = strm;
  1696. }
  1697.  
  1698. siLcopy_stream()
  1699. {
  1700.     object in, out;
  1701.  
  1702.     check_arg(2);
  1703.     check_type_stream(&vs_base[0]);
  1704.     check_type_stream(&vs_base[1]);
  1705.     in = vs_base[0];
  1706.     out = vs_base[1];
  1707.     while (!stream_at_end(in))
  1708.         writec_stream(readc_stream(in), out);
  1709.     flush_stream(out);
  1710.     vs_base[0] = Ct;
  1711.     vs_pop;
  1712. #ifdef AOSVS
  1713.  
  1714. #endif
  1715. }
  1716.  
  1717.  
  1718. too_long_file_name(fn)
  1719. object fn;
  1720. {
  1721.     FEerror("~S is a too long file name.", 1, fn);
  1722. }
  1723.  
  1724. cannot_open(fn)
  1725. object fn;
  1726. {
  1727.     FEerror("Cannot open the file ~A.", 1, fn);
  1728. }
  1729.  
  1730. cannot_create(fn)
  1731. object fn;
  1732. {
  1733.     FEerror("Cannot create the file ~A.", 1, fn);
  1734. }
  1735.  
  1736. cannot_read(strm)
  1737. object strm;
  1738. {
  1739.     FEerror("Cannot read the stream ~S.", 1, strm);
  1740. }
  1741.  
  1742. cannot_write(strm)
  1743. object strm;
  1744. {
  1745.     FEerror("Cannot write to the stream ~S.", 1, strm);
  1746. }
  1747.  
  1748. #ifdef USER_DEFINED_STREAMS
  1749. /* more support for user defined streams */
  1750. siLuser_stream_state()
  1751. {     
  1752.   check_arg(1);
  1753.  
  1754.   if(vs_base[0]->sm.sm_object1)
  1755.       vs_base[0] = vs_base[0]->sm.sm_object1->str.str_self[0]; 
  1756.   else
  1757.     FEerror("Stream data NULL ~S", 1, vs_base[0]);
  1758. }
  1759. #endif
  1760.  
  1761. closed_stream(strm)
  1762. object strm;
  1763. {
  1764.     FEerror("The stream ~S is already closed.", 1, strm);
  1765. }
  1766.  
  1767.  
  1768.  
  1769. /* returns a stream with which one can safely do fwrite to the x->sm.sm_fp
  1770.    or nil.
  1771.    */
  1772.  
  1773.  
  1774. /* coerce stream to one so that x->sm.sm_fp is suitable for fread and fwrite,
  1775.    Return nil if this is not possible.
  1776.    */
  1777.  
  1778. object
  1779. coerce_stream(strm,out)
  1780. object strm;
  1781. int out;
  1782. {
  1783.  BEGIN:
  1784.  if (type_of(strm) != t_stream)
  1785.    FEwrong_type_argument(Sstream, strm);
  1786.  switch (strm->sm.sm_mode){
  1787.  case smm_synonym:
  1788.   strm = symbol_value(strm->sm.sm_object0);
  1789.   if (type_of(strm) != t_stream)
  1790.             FEwrong_type_argument(Sstream, strm);
  1791.         goto BEGIN;
  1792.  
  1793.  case smm_two_way:
  1794.  case smm_echo:
  1795.   if (out)strm = strm->sm.sm_object1;
  1796.     else strm = strm->sm.sm_object0;
  1797.   goto BEGIN;
  1798.  case smm_output:
  1799.   if (!out) cannot_read(strm);
  1800.   break;
  1801.  case smm_input:
  1802.     if (out) cannot_write(strm);
  1803.   break;
  1804.  default:
  1805.   strm=Cnil;
  1806.   }
  1807.  if (strm!=Cnil
  1808.      && (strm->sm.sm_fp == NULL))
  1809.    closed_stream(strm);
  1810.  return(strm);
  1811. }
  1812.  
  1813. siLfp_output_stream()
  1814. {check_arg(1);
  1815.  vs_base[0]=coerce_stream(vs_base[0],1);
  1816. }
  1817.  
  1818. siLfp_input_stream()
  1819. {check_arg(1);
  1820.  vs_base[0]=coerce_stream(vs_base[0],0);
  1821. }
  1822.  
  1823.  
  1824. @(defun fwrite (vector start count stream)
  1825.   unsigned char *p;
  1826.   int n,beg;
  1827. @  
  1828.   stream=coerce_stream(stream,1);
  1829.   if (stream==Cnil) @(return Cnil);
  1830.   p = vector->ust.ust_self;
  1831.   beg = ((type_of(start)==t_fixnum) ? fix(start) : 0);
  1832.   n = ((type_of(count)==t_fixnum) ? fix(count) : (vector->st.st_fillp - beg));
  1833.   if (fwrite(p+beg,1,n,stream->sm.sm_fp)) @(return Ct);
  1834.   @(return Cnil);
  1835. @)
  1836.  
  1837. @(defun fread (vector start count stream)
  1838.   unsigned char *p;
  1839.   int n,beg;
  1840. @  
  1841.   stream=coerce_stream(stream,0);
  1842.   if (stream==Cnil) @(return Cnil);
  1843.   p = vector->ust.ust_self;
  1844.   beg = ((type_of(start)==t_fixnum) ? fix(start) : 0);
  1845.   n = ((type_of(count)==t_fixnum) ? fix(count) : (vector->st.st_fillp - beg));
  1846.   if (n=fread(p+beg,1,n,stream->sm.sm_fp))
  1847.       @(return `make_fixnum(n)`);
  1848.   @(return Cnil);
  1849. @)
  1850.  
  1851.  
  1852.  
  1853. init_file()
  1854. {
  1855.     object standard_input;
  1856.     object standard_output;
  1857.     object standard;
  1858.     object x;
  1859. #ifdef AOSVS1
  1860.  
  1861.  
  1862.  
  1863. #endif
  1864.  
  1865.     standard_input = alloc_object(t_stream);
  1866.     standard_input->sm.sm_mode = (short)smm_input;
  1867.     standard_input->sm.sm_fp = stdin;
  1868.     standard_input->sm.sm_object0 = Sstring_char;
  1869.     standard_input->sm.sm_object1
  1870. #ifdef UNIX
  1871.     = make_simple_string("stdin");
  1872. #endif
  1873. #ifdef AOSVS
  1874.  
  1875. #endif
  1876.     standard_input->sm.sm_int0 = 0;
  1877.     standard_input->sm.sm_int1 = 0;
  1878.  
  1879.     standard_output = alloc_object(t_stream);
  1880.     standard_output->sm.sm_mode = (short)smm_output;
  1881.     standard_output->sm.sm_fp = stdout;
  1882.     standard_output->sm.sm_object0 = Sstring_char;
  1883.     standard_output->sm.sm_object1
  1884. #ifdef UNIX
  1885.     = make_simple_string("stdout");
  1886. #endif
  1887. #ifdef AOSVS
  1888.  
  1889. #endif
  1890.     standard_output->sm.sm_int0 = 0;
  1891.     standard_output->sm.sm_int1 = 0;
  1892.  
  1893.     terminal_io = standard
  1894.     = make_two_way_stream(standard_input, standard_output);
  1895.     enter_mark_origin(&terminal_io);
  1896.  
  1897.     Vterminal_io
  1898.     = make_special("*TERMINAL-IO*", standard);
  1899.  
  1900.     x = alloc_object(t_stream);
  1901.     x->sm.sm_mode = (short)smm_synonym;
  1902.     x->sm.sm_fp = NULL;
  1903.     x->sm.sm_object0 = Vterminal_io;
  1904.     x->sm.sm_object1 = OBJNULL;
  1905.     x->sm.sm_int0 = x->sm.sm_int1 = 0;
  1906.     standard = x;
  1907.  
  1908.     Vstandard_input
  1909.     = make_special("*STANDARD-INPUT*", standard);
  1910.     Vstandard_output
  1911.     = make_special("*STANDARD-OUTPUT*", standard);
  1912.     Verror_output
  1913.     = make_special("*ERROR-OUTPUT*", standard);
  1914.  
  1915. #ifdef AOSVS1
  1916.  
  1917.  
  1918.  
  1919.  
  1920.  
  1921.  
  1922.  
  1923.  
  1924.  
  1925.  
  1926.  
  1927.  
  1928.  
  1929.  
  1930. #endif
  1931.  
  1932.     Vquery_io
  1933.     = make_special("*QUERY-IO*", standard);
  1934.     Vdebug_io
  1935.     = make_special("*DEBUG-IO*", standard);
  1936.     Vtrace_output
  1937.     = make_special("*TRACE-OUTPUT*", standard);
  1938.  
  1939. #ifdef AOSVS1
  1940.  
  1941.  
  1942.  
  1943.  
  1944.  
  1945.  
  1946.  
  1947.  
  1948.  
  1949.  
  1950.  
  1951.  
  1952.  
  1953.  
  1954.  
  1955.  
  1956.  
  1957.  
  1958.  
  1959. #endif
  1960. }
  1961.  
  1962. init_file_function()
  1963. {
  1964.     Kabort = make_keyword("ABORT");
  1965.  
  1966.     Kdirection = make_keyword("DIRECTION");
  1967.     Kinput = make_keyword("INPUT");
  1968.     Koutput = make_keyword("OUTPUT");
  1969.     Kio = make_keyword("IO");
  1970.     Kprobe = make_keyword("PROBE");
  1971.     Kelement_type = make_keyword("ELEMENT-TYPE");
  1972.     Kdefault = make_keyword("DEFAULT");
  1973.     Kif_exists = make_keyword("IF-EXISTS");
  1974.     Kerror = make_keyword("ERROR");
  1975.     Knew_version = make_keyword("NEW-VERSION");
  1976.     Krename = make_keyword("RENAME");
  1977.     Krename_and_delete = make_keyword("RENAME-AND-DELETE");
  1978.     Koverwrite = make_keyword("OVERWRITE");
  1979.     Kappend = make_keyword("APPEND");
  1980.     Ksupersede = make_keyword("SUPERSEDE");
  1981.     Kif_does_not_exist = make_keyword("IF-DOES-NOT-EXIST");
  1982.     /*  Kerror = make_keyword("ERROR");  */
  1983.     Kcreate = make_keyword("CREATE");
  1984.  
  1985.     Kprint = make_keyword("PRINT");
  1986.     Kverbose = make_keyword("VERBOSE");
  1987.     Kif_does_not_exist = make_keyword("IF-DOES-NOT-EXIST");
  1988.     Kset_default_pathname = make_keyword("SET-DEFAULT-PATHNAME");
  1989.  
  1990.     Vload_verbose = make_special("*LOAD-VERBOSE*", Ct);
  1991.     siVload_pathname = make_si_special("*LOAD-PATHNAME*",Cnil);
  1992.  
  1993. #ifdef UNIX
  1994.     FASL_string = make_simple_string("o");
  1995.     make_si_constant("*EOF*",make_fixnum(EOF));
  1996. #endif
  1997. #ifdef AOSVS
  1998.  
  1999. #endif
  2000.     enter_mark_origin(&FASL_string);
  2001. #ifdef UNIX
  2002.     LSP_string = make_simple_string("lsp");
  2003. #endif
  2004. #ifdef AOSVS
  2005.  
  2006. #endif
  2007.     enter_mark_origin(&LSP_string);
  2008.     make_si_function("FP-INPUT-STREAM",    siLfp_input_stream);
  2009.     make_si_function("FP-OUTPUT-STREAM",    siLfp_output_stream);
  2010.  
  2011.     make_function("MAKE-SYNONYM-STREAM", Lmake_synonym_stream);
  2012.     make_function("MAKE-BROADCAST-STREAM", Lmake_broadcast_stream);
  2013.     make_function("MAKE-CONCATENATED-STREAM",
  2014.               Lmake_concatenated_stream);
  2015.     make_function("MAKE-TWO-WAY-STREAM", Lmake_two_way_stream);
  2016.     make_function("MAKE-ECHO-STREAM", Lmake_echo_stream);
  2017.     make_function("MAKE-STRING-INPUT-STREAM",
  2018.               Lmake_string_input_stream);
  2019.     make_function("MAKE-STRING-OUTPUT-STREAM",
  2020.               Lmake_string_output_stream);
  2021.     make_function("GET-OUTPUT-STREAM-STRING",
  2022.               Lget_output_stream_string);
  2023.  
  2024.     make_si_function("OUTPUT-STREAM-STRING", siLoutput_stream_string);
  2025.     make_si_function("FWRITE",Lfwrite);
  2026.     make_si_function("FREAD",Lfread);
  2027.     make_function("STREAMP", Lstreamp);
  2028.     make_function("INPUT-STREAM-P", Linput_stream_p);
  2029.     make_function("OUTPUT-STREAM-P", Loutput_stream_p);
  2030.     make_function("STREAM-ELEMENT-TYPE", Lstream_element_type);
  2031.     make_function("CLOSE", Lclose);
  2032.  
  2033.     make_function("OPEN", Lopen);
  2034.  
  2035.     make_function("FILE-POSITION", Lfile_position);
  2036.     make_function("FILE-LENGTH", Lfile_length);
  2037.  
  2038.     make_function("LOAD", Lload);
  2039.  
  2040.     make_si_function("GET-STRING-INPUT-STREAM-INDEX",
  2041.              siLget_string_input_stream_index);
  2042.     make_si_function("MAKE-STRING-OUTPUT-STREAM-FROM-STRING",
  2043.              siLmake_string_output_stream_from_string);
  2044.     make_si_function("COPY-STREAM", siLcopy_stream);
  2045.  
  2046. #ifdef USER_DEFINED_STREAMS
  2047.     make_si_function("USER-STREAM-STATE", siLuser_stream_state);
  2048. #endif
  2049.     siVignore_eof_on_terminal_io
  2050.     = make_si_special("*IGNORE-EOF-ON-TERMINAL-IO*", Cnil);
  2051. }
  2052.  
  2053.  
  2054. object
  2055. read_fasl_data(str)
  2056. char *str;
  2057. {
  2058.     object faslfile, data;
  2059. #ifdef UNIX
  2060.     FILE *fp;
  2061.  
  2062.  
  2063. #ifdef BSD
  2064. #ifdef HAVE_AOUT
  2065.      struct exec header;
  2066. #endif
  2067. #endif
  2068. #ifdef ATT
  2069.     struct filehdr fileheader;
  2070. #endif
  2071. #ifdef E15
  2072.     struct exec header;
  2073. #endif
  2074.     int i;
  2075. #endif
  2076.         vs_mark;
  2077.  
  2078.     faslfile = make_simple_string(str);
  2079.     vs_push(faslfile);
  2080.     faslfile = open_stream(faslfile, smm_input, Cnil, Kerror);
  2081.     vs_push(faslfile);
  2082.  
  2083. #ifdef SEEK_TO_END_OFILE
  2084.      SEEK_TO_END_OFILE(faslfile->sm.sm_fp);
  2085. #else
  2086.  
  2087. #ifdef BSD
  2088.     fp = faslfile->sm.sm_fp;
  2089.     fread(&header, sizeof(header), 1, fp);
  2090.     fseek(fp,
  2091.           header.a_text+header.a_data+
  2092.           header.a_syms+header.a_trsize+header.a_drsize,
  2093.           1);
  2094.     fread(&i, sizeof(i), 1, fp);
  2095.     fseek(fp, i - sizeof(i), 1);
  2096. #endif
  2097.  
  2098. #ifdef ATT
  2099.     fp = faslfile->sm.sm_fp;
  2100.     fread(&fileheader, sizeof(fileheader), 1, fp);
  2101.     fseek(fp,
  2102.           fileheader.f_symptr+fileheader.f_nsyms*SYMESZ,
  2103.           0);
  2104.     fread(&i, sizeof(i), 1, fp);
  2105.     fseek(fp, i - sizeof(i), 1);
  2106.     while ((i = getc(fp)) == 0)
  2107.         ;
  2108.     ungetc(i, fp);
  2109. #endif
  2110.  
  2111. #ifdef E15
  2112.     fp = faslfile->sm.sm_fp;
  2113.     fread(&header, sizeof(header), 1, fp);
  2114.     fseek(fp,
  2115.           header.a_text+header.a_data+
  2116.           header.a_syms+header.a_trsize+header.a_drsize,
  2117.           1);
  2118. #endif
  2119.  
  2120. #ifdef DGUX
  2121.  
  2122.  
  2123.  
  2124.  
  2125. #endif
  2126.  
  2127. #ifdef AOSVS
  2128.  
  2129.  
  2130.  
  2131.  
  2132. #endif
  2133. #endif
  2134.     data = read_fasl_vector(faslfile);
  2135.  
  2136.     vs_push(data);
  2137.     close_stream(faslfile, TRUE);
  2138.     vs_reset;
  2139.     return(data);
  2140. }
  2141.