home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD2.bin / bbs / dev / umbscheme-2.12.lha / UMBScheme / src / io.c < prev    next >
C/C++ Source or Header  |  1993-11-29  |  14KB  |  724 lines
  1. /* io.c -- UMB Scheme, I/O package.
  2.  
  3. UMB Scheme Interpreter                  $Revision: 2.12 $
  4. Copyright (C) 1988, 1991 William R Campbell
  5.  
  6. This program is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. This program is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with this program; if not, write to the Free Software
  18. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. UMB Scheme was written by Bill Campbell with help from Karl Berry,
  21. Barbara Dixey, Ira Gerstein, Mary Glaser, Kathy Hargreaves, Bill McCabe,
  22. Long Nguyen, Susan Quina, Jeyashree Sivasubram, Bela Sohoni and Thang Quoc Tran.
  23.  
  24. For additional information about UMB Scheme, contact the author:
  25.  
  26.     Bill Campbell
  27.     Department of Mathematics and Computer Science
  28.     University of Massachusetts at Boston
  29.     Harbor Campus
  30.     Boston, MA 02125
  31.  
  32.     Telephone: 617-287-6449        Internet: bill@cs.umb.edu
  33.  
  34. */
  35.  
  36. #include "portable.h"
  37. #include "eval.h"
  38. #include "object.h"
  39. #include "architecture.h"
  40. #include "steering.h"
  41. #include "primitive.h"
  42. #include "io.h"
  43. #include "number.h"
  44.  
  45. Public FILE *The_Standard_Input, *The_Standard_Output;
  46.  
  47.  
  48. /* A static variable printing keeps track of whether we want to print or not.*/
  49.  
  50. Private Boolean printing = TRUE;
  51.  
  52. Public void Set_Printing(turn_it_on)
  53.     Boolean turn_it_on;
  54. {
  55.     printing = turn_it_on;
  56. }
  57.  
  58. Public Boolean Get_Printing_State()
  59. {
  60.     return printing;
  61. }
  62.  
  63.  
  64. /* The routines that actually print somewhere. |Output| assumes that its 
  65. argument will not have a null. */
  66.  
  67. Public void Output(s)
  68.  
  69.     String s;
  70. {
  71.     fprintf(Get_Port_File(Current_Output_Port), "%s", s);
  72.  
  73.     if ( The_Transcript_Port != Nil )
  74.     { 
  75.         fprintf(Get_Port_File(The_Transcript_Port), "%s", s);
  76.     }
  77. }
  78.  
  79. /* |Output_Char| should perhaps do something about control characters. 
  80. When printing to the terminal, we certainly don't want to send control 
  81. characters, for example. */
  82.  
  83. Public void Output_Char(c)
  84.  
  85.     Character c;
  86. {
  87.     fprintf(Get_Port_File(Current_Output_Port), "%c", c);
  88.  
  89.     if ( The_Transcript_Port != Nil )
  90.     { 
  91.         fprintf(Get_Port_File(The_Transcript_Port), "%c", c);
  92.     }
  93. }
  94.  
  95. Public    Integer    New_Left_Margin( margin )
  96.     
  97.     Integer    margin;
  98. {
  99.     Integer    in_margin = margin;
  100.     Output( "\n" );
  101.     while ( margin-- > 0 )
  102.         Output( " " );
  103.     return( in_margin );
  104. }
  105.  
  106. Public void Print_Type(t)
  107.     Scheme_Type t;
  108. {
  109.     if (Boolean_Type == t) 
  110.     {
  111.         Output( "Boolean" ); 
  112.     }
  113.     if (Eclectic_Type == t) 
  114.     { 
  115.         Output( "Eclectic" ); 
  116.     }
  117.     if (Pair_Type == t) 
  118.     { 
  119.         Output( "Pair" ); 
  120.     }
  121.     if (Empty_List_Type == t) 
  122.     { 
  123.         Output( "Empty_List" ); 
  124.     }
  125.     if (Symbol_Type == t) 
  126.     { 
  127.         Output( "Symbol" ); 
  128.     }
  129.     if (Number_Type == t) 
  130.     { 
  131.         Output( "Number" ); 
  132.     }
  133.     if (Character_Type == t) 
  134.     { 
  135.         Output( "Character" ); 
  136.     }
  137.     if (String_Type == t) 
  138.     { 
  139.         Output( "String" ); 
  140.     }
  141.     if (Vector_Type == t) 
  142.     { 
  143.         Output( "Vector" ); 
  144.     }
  145.     if (Procedure_Type == t) 
  146.     { 
  147.         Output( "Procedure" ); 
  148.     }
  149.     if (Primitive_Type == t) 
  150.     { 
  151.         Output( "Primitive" ); 
  152.     }
  153.     if (Continuation_Type == t) 
  154.     { 
  155.         Output( "Continuation" ); 
  156.     }
  157.     if (Port_Type == t) 
  158.     { 
  159.         Output( "Port" ); 
  160.     }
  161.     if (Eof_Type == t) 
  162.     { 
  163.         Output( "Eof" ); 
  164.     }
  165.     if (Variable_Type == t) 
  166.     { 
  167.         Output( "Variable" ); 
  168.     }
  169.     if (Apply_Type == t) 
  170.     { 
  171.         Output( "Apply" ); 
  172.     }
  173.     if (Lambda_Type == t) 
  174.     { 
  175.         Output( "Lambda" ); 
  176.     }
  177.     if (Conditional_Type == t) 
  178.     { 
  179.         Output( "Conditional" ); 
  180.     }
  181.     if (Assignment_Type == t) 
  182.     { 
  183.         Output( "Assignment" ); 
  184.     }
  185.     if (Definition_Type == t) 
  186.     { 
  187.         Output( "Definition" ); 
  188.     }
  189.     if (Macro_Type == t) 
  190.     { 
  191.         Output( "Macro" ); 
  192.     }
  193.     if (Macro_Call_Type == t) 
  194.     { 
  195.         Output( "Macro_Call" ); 
  196.     }
  197.     if (Sequence_Type == t) 
  198.     { 
  199.         Output( "Sequence" ); 
  200.     }
  201.     if (Delay_Type == t) 
  202.     { 
  203.         Output( "Delay" ); 
  204.     }
  205.     if (Promise_Type == t) 
  206.     { 
  207.         Output( "Promise" ); 
  208.     }
  209.     if (Error_Type == t) 
  210.     { 
  211.         Output( "Error" ); 
  212.     }
  213.     if (Environment_Frame_Type == t) 
  214.     { 
  215.         Output( "Environment_Frame" ); 
  216.     }
  217.     if (State_Frame_Type == t) 
  218.     { 
  219.         Output( "State_Frame" ); 
  220.     }
  221.     if (Any_Type == t) 
  222.     { 
  223.         Output( "Any" ); 
  224.     }
  225. }
  226.  
  227. /* Reading. */
  228.  
  229. #define    MAX_TOKEN_SIZE 1000
  230.  
  231. typedef enum
  232. {
  233.     Lparen_Token,    Rparen_Token,    Quote_Token,    Backquote_Token,
  234.     Dot_Token,    Comma_Token,    Open_Vec_Token,    True_Token,
  235.     False_Token,    String_Token,    Number_Token,    Character_Token,
  236.     Symbol_Token,    Error_Token,    Comma_At_Token,    Eof_Token
  237. } 
  238. Token ;
  239.  
  240. Private    Token    The_Token ;
  241. Private    String Token_String ;
  242. Private    Character Token_Buffer[ MAX_TOKEN_SIZE ] ;
  243. Private    Integer    Token_Index ;
  244. Private    Boolean Transcripting = FALSE;
  245.  
  246. #define Is_Control_Char iscntrl
  247. #define    Is_White_Space    isspace 
  248.  
  249. #define Scan_Char(f)    (Transcripting?Tscan(f):getc(f))
  250.  
  251. Private    void Read_Number() ;
  252. Private    void Read_Symbol() ;
  253. Private int  Force_Lower() ;
  254. Private void Read_Token();
  255. Private void Read_List();
  256.  
  257.  
  258. /* Auxiliary input routines. */
  259.  
  260. Private    int    Tscan( f )
  261.  
  262.     FILE *    f;
  263. {
  264.     int c; 
  265.     if ( (c = getc(f)) != EOF ) putc(c , Get_Port_File(The_Transcript_Port));
  266.     return( c );
  267. }
  268.  
  269.     
  270.  
  271. Private Boolean Is_Delimiter(c)
  272.  
  273.     int    c;
  274. {
  275.     return( Is_White_Space(c) || c == '(' || c == ')' || c == '"' || 
  276.         c == ';' || c == EOF);
  277. }
  278.  
  279.  
  280. /* Force uppercase letters (and only letters) to lowercase. */
  281. Private    int Force_Lower( Ch )
  282.     int    Ch ;
  283. {
  284.     return( isupper( Ch ) ? (Ch - 'A' + 'a') : Ch ) ;
  285. }
  286.  
  287.  
  288. /* Implement the ANSI routine `toint'. */
  289.  
  290. Public Integer toint(c)
  291.     int    c;
  292. {
  293.     if (isxdigit(c))
  294.     {
  295.         c = Force_Lower(c);
  296.         if (c >= 'a')
  297.             return c - 'a' + 10;
  298.         else
  299.             return c - '0';
  300.     }
  301.     else 
  302.     {
  303.         Panic( "Non-hex digit passed to toint" );
  304.         return 0;
  305.     }
  306. }
  307.  
  308. /* Read a Scheme object from |Input_File|; leave it in Value_Register. */
  309.  
  310. Public    void Read( Input_File )
  311.  
  312.     FILE*    Input_File ;
  313. {
  314.     Transcripting = The_Transcript_Port != Nil 
  315.                 &&  Input_File == The_Standard_Input; 
  316.  
  317.     Read_Token( Input_File ) ;
  318.  
  319.     switch( The_Token )
  320.     {
  321.     case Symbol_Token :
  322.         Value_Register = Intern_Name( Token_String ) ;
  323.         break ;
  324.  
  325.     case Lparen_Token :
  326.         Read_List( Input_File ) ;
  327.         break ;
  328.  
  329.     case Number_Token :
  330.         Cstring_To_Number( Token_String , 0 ) ;
  331.         break ;
  332.  
  333.     case String_Token :
  334.         /* We want to allow nulls in string constants. Hence
  335.                    |memcpy| instead of |strcpy|. */
  336.         Make_String( Token_Index );
  337.         memcpy( Get_String_Value(Value_Register), Token_Buffer, 
  338.             Token_Index );
  339.         Get_String_Value( Value_Register ) [ Token_Index ] = '\0';
  340.         break ;
  341.  
  342.     case Character_Token :
  343.         Make_Character( *Token_String ) ;
  344.         break ;
  345.  
  346.     case True_Token :
  347.         Value_Register = The_True_Object ;
  348.         break ;
  349.  
  350.     case False_Token :
  351.         Value_Register = The_False_Object ;
  352.         break ;
  353.         
  354.         case Open_Vec_Token :
  355.         Read_List( Input_File ) ;
  356.         Push( Value_Register ) ;
  357.         List_To_Vector() ;
  358.         Pop( 1 ) ;
  359.         break ;
  360.  
  361.     case Dot_Token :
  362.         Value_Register = The_Dot_Object ;
  363.         break ;
  364.  
  365.     case Rparen_Token :
  366.         Value_Register = The_Rparen_Object ;
  367.         break ;
  368.  
  369.     case Quote_Token :
  370.         Push( Intern_Name( "quote" ) ) ;
  371.         Read( Input_File ) ;
  372.         Push( Value_Register ) ;
  373.         Push( Nil ) ;
  374.         Make_Pair() ;
  375.         Push( Value_Register ) ;
  376.         Make_Pair() ;
  377.         break ;
  378.  
  379.     case Backquote_Token :
  380.         Push( Intern_Name( "quasiquote" ) ) ;
  381.         Read( Input_File ) ;
  382.         Push( Value_Register ) ;
  383.         Push( Nil ) ;
  384.         Make_Pair() ;
  385.         Push( Value_Register ) ;
  386.         Make_Pair() ;
  387.         break ;
  388.  
  389.     case Comma_Token :
  390.         Push( Intern_Name( "unquote" ) ) ;
  391.         Read( Input_File ) ;
  392.         Push( Value_Register ) ;
  393.         Push( Nil ) ;
  394.         Make_Pair() ;
  395.         Push( Value_Register ) ;
  396.         Make_Pair() ;
  397.         break ;
  398.  
  399.     case Comma_At_Token :
  400.         Push( Intern_Name( "unquote-splicing" ) ) ;
  401.         Read( Input_File ) ;
  402.         Push( Value_Register ) ;
  403.         Push( Nil ) ;
  404.         Make_Pair() ;
  405.         Push( Value_Register ) ;
  406.         Make_Pair() ;
  407.         break ;
  408.  
  409.     case Error_Token :
  410.         Make_Error( Token_String ) ;
  411.         break ;
  412.  
  413.     case Eof_Token :
  414.         Value_Register = The_Eof_Object ;
  415.         break ;
  416.  
  417.     default :
  418.         Panic( "Unidentified token" ) ;
  419.         break ;
  420.     }
  421. }
  422.  
  423.  
  424. /* Read list from Input_File and leave it in Value_Register. This allows 
  425. the input `( . x )' (it treats it as equivalent to x), which is not strictly 
  426. legal according