home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / oct93 / develop / umbscheme.lha / UMBScheme / src / object.c < prev    next >
C/C++ Source or Header  |  1992-08-04  |  42KB  |  2,147 lines
  1. /* object.c -- UMB Scheme, object package.
  2.  
  3. UMB Scheme Interpreter                  $Revision: 2.5 $
  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 "compiler.h"
  41. #include "steering.h"
  42. #include "io.h"
  43. #include "primitive.h"
  44. #include "number.h"
  45.  
  46. #define    INDENT 2 
  47.  
  48. /* Boolean. */
  49.  
  50. Op_Vector Boolean_Ops = { Self_Eval, Self_Compile, 
  51.             Boolean_Print, Boolean_Print, Boolean_Print, Boolean_GC};
  52.  
  53. Scheme_Type Boolean_Type = &Boolean_Ops;
  54.  
  55. Object The_True_Object, The_False_Object;
  56.  
  57. Private void Init_Boolean()
  58.  
  59. {
  60.     The_True_Object = Allocate(Boolean_Size);
  61.     The_False_Object = Allocate(Boolean_Size);
  62.  
  63.     Get_Type(The_True_Object) = Boolean_Type;
  64.     Get_Type_Name(The_True_Object) = "Boolean_Type/t";
  65.     Get_Type(The_False_Object) = Boolean_Type;
  66.     Get_Type_Name(The_False_Object) = "Boolean_Type/f";
  67. }
  68.  
  69. Public Integer Boolean_Print(o,m)
  70.  
  71.     Object    o;
  72.     Integer    m;
  73. {
  74.     if (o == The_True_Object)
  75.         Output("#t");
  76.     else if (o == The_False_Object)
  77.         Output("#f");
  78.     else
  79.         Panic("Boolean_Print called on a non-boolean");
  80.     return( m+2 );
  81. }
  82.  
  83. Public Object Boolean_GC(old)
  84.  
  85.     Object old;
  86. {
  87.     Object new = Move_Object(old, Boolean_Size);
  88.  
  89.     return new;
  90. }
  91.  
  92. /* Pair. */
  93.  
  94. Op_Vector Pair_Ops = {
  95.     Self_Eval, Compile_Form, Pair_Display, Pair_Write, Pair_Show, Pair_GC};
  96.  
  97. Scheme_Type Pair_Type = &Pair_Ops;
  98.  
  99. /* Make_Pair Car Cdr, i.e., Car is Top(2), Cdr is Top(1). In
  100. other words, push the car first, then the cdr. */
  101. Public    void Make_Pair()
  102. {
  103.     Value_Register = Allocate(Pair_Size);
  104.     Get_Pair_Car(Value_Register) = Top(2);
  105.     Get_Pair_Cdr(Value_Register) = Top(1);
  106.  
  107.     Set_Result_Type(Pair_Type);
  108.     Pop(2);
  109. }
  110.  
  111.  
  112. Public    Integer Pair_Write( o , m )
  113.  
  114.     Object    o;
  115.     Integer    m;
  116. {
  117.     Output( "(" ); m += 1;
  118.     
  119.     m = Write_Object( Get_Pair_Car( o ) , m );
  120.     o = Get_Pair_Cdr( o );
  121.  
  122.     while ( Is_Pair( o ) )
  123.     {
  124.         Output( " " );  m += 1;
  125.         m = Write_Object( Get_Pair_Car( o ) , m );
  126.         o = Get_Pair_Cdr( o );
  127.     }
  128.  
  129.     if ( o == Nil )
  130.     {
  131.         Output( ")" ); m += 1;
  132.     }
  133.     else
  134.     {
  135.         Output( " . " ); m += 2;
  136.         m = Write_Object( o , m );
  137.         Output( ")" );  m += 1;
  138.     }
  139.     return( m );
  140. }
  141.  
  142. Public    Integer Pair_Display( o , m )
  143.  
  144.     Object    o;
  145.     Integer    m;
  146. {
  147.     Output( "(" ); m += 1;
  148.     
  149.     m = Display_Object( Get_Pair_Car( o ) , m );
  150.     o = Get_Pair_Cdr( o );
  151.  
  152.     while ( Is_Pair( o ) )
  153.     {
  154.         Output( " " );  m += 1;
  155.         m = Display_Object( Get_Pair_Car( o ) , m );
  156.         o = Get_Pair_Cdr( o );
  157.     }
  158.  
  159.     if ( o == Nil )
  160.     {
  161.         Output( ")" ); m += 1;
  162.     }
  163.     else
  164.     {
  165.         Output( " . " ); m += 2;
  166.         m = Display_Object( o , m );
  167.         Output( ")" );  m += 1;
  168.     }
  169.     return( m );
  170. }
  171.  
  172.  
  173. Public    Integer    Pair_Show( o, m )
  174.  
  175.     Object    o;
  176.     Integer    m;
  177. {
  178.     Integer length = Length(o);
  179.  
  180.     if  (length > 3)
  181.     {
  182.         Output("("); m += 1;
  183.         m = Write_Object( First(o) , m ) + 1; Output( " " );
  184.         m = Write_Object( Second(o) , m ) + 1; Output( " " );
  185.         m = Write_Object( Third(o) , m ) + 1; Output( " " );
  186.         Output( "...)" ); m += 4;
  187.     }
  188.     else
  189.     {
  190.         Pair_Write( o , m );
  191.     }
  192.  
  193.     return( m );
  194. }
  195.  
  196. Public Object Pair_GC(old)
  197.  
  198.     Object old;
  199. {
  200.     Object new = Move_Object(old, Pair_Size);
  201.  
  202.     Relocate(&Get_Pair_Car(new));
  203.     Relocate(&Get_Pair_Cdr(new));
  204.  
  205.     return new;
  206. }
  207.  
  208.  
  209. /* These internal routines are not directly callable from Lisp. We assume 
  210. `list' is a list, but no more. */
  211.  
  212. Integer Length(list)
  213.  
  214.     Object list;
  215. {
  216.     Integer length = 0;
  217.  
  218.     while (Is_Pair(list))
  219.     {
  220.         list = Get_Pair_Cdr(list);
  221.         length++;
  222.     }
  223.  
  224.     return length;
  225. }
  226.  
  227. Private Object Last_Cdr(list)
  228.         
  229.     Object list;
  230. {
  231.     while (Is_Pair(list))
  232.     {
  233.         list = Get_Pair_Cdr(list);
  234.     }
  235.  
  236.     return list;
  237. }
  238.  
  239. Public Object First(list)
  240.  
  241.     Object list;
  242. {
  243.     if (! Is_Pair(list))
  244.     {
  245.         Display_Error("Syntax error in First: list doesn't have a car",
  246.             list);
  247.         return Nil;
  248.     }
  249.  
  250.     return Get_Pair_Car(list);
  251. }
  252.  
  253. Public Object Rest(list)
  254.     
  255.     Object list;
  256. {
  257.     if (! Is_Pair(list))
  258.     {
  259.         Display_Error("Syntax error in Rest: list doesn't have a cdr",
  260.             list);
  261.         return Nil;
  262.     }
  263.  
  264.     return Get_Pair_Cdr(list);
  265. }
  266.  
  267. Object Second(list)
  268.  
  269.     Object list;
  270. {
  271.     if (!Is_Pair(list) || !Is_Pair(Get_Pair_Cdr(list)))
  272.     {
  273.     Display_Error(
  274.         "Syntax error in second: list doesn't have two elements",
  275.          list);
  276.         return Nil;
  277.     }
  278.     return Get_Pair_Car(Get_Pair_Cdr(list));
  279. }
  280.  
  281. Object Third(list)
  282.  
  283.     Object list;
  284. {
  285.     if (!Is_Pair(list) || !Is_Pair(Get_Pair_Cdr(list))
  286.         || !Is_Pair(Get_Pair_Cdr(Get_Pair_Cdr(list))))
  287.     {
  288.         Display_Error(
  289.         "Syntax error in third: list doesn't have three elements",
  290.              list);
  291.         return Nil;
  292.     }
  293.  
  294.     return Get_Pair_Car(Get_Pair_Cdr(Get_Pair_Cdr(list)));
  295. }
  296.  
  297. Object Fourth(list)
  298.  
  299.     Object list;
  300. {
  301.     if (!Is_Pair(list)
  302.         || !Is_Pair(Get_Pair_Cdr(list))
  303.         || !Is_Pair(Get_Pair_Cdr(Get_Pair_Cdr(list)))
  304.         || !Is_Pair(Get_Pair_Cdr(Get_Pair_Cdr(Get_Pair_Cdr(list))))
  305.         )
  306.     {
  307.         Display_Error(
  308.         "Syntax error in fourth: list doesn't have four elements",
  309.              list);
  310.         return Nil;
  311.     }
  312.  
  313.     return Get_Pair_Car(Get_Pair_Cdr(Get_Pair_Cdr(Get_Pair_Cdr(list))));
  314. }
  315.  
  316. Public    Boolean    Member( item , list )
  317.  
  318.     Object    item , list;
  319. {
  320.     while ( Is_Pair( list ) )
  321.     {
  322.         if ( Get_Pair_Car( list ) == item ) return( TRUE );
  323.         list = Get_Pair_Cdr( list );
  324.     }
  325.     return( FALSE );
  326. }
  327.  
  328. /* Empty List. */
  329.  
  330. Op_Vector Empty_List_Ops = {
  331.     Self_Eval, Compile_The_Empty_Object,
  332.     Empty_List_Print, Empty_List_Print, Empty_List_Print,
  333.     Empty_List_GC};
  334.  
  335. Scheme_Type Empty_List_Type = &Empty_List_Ops;
  336.  
  337. Public Object Nil;
  338.  
  339. Private void Init_Empty_List()
  340.  
  341. {
  342.     Nil = Allocate(Empty_List_Size);
  343.  
  344.     Get_Type(Nil) = Empty_List_Type;
  345.     Get_Type_Name(Nil) = "Empty_List_Type";
  346. }
  347.  
  348. Public    Integer Empty_List_Print( o, m )
  349.  
  350.     Object    o;
  351.     Integer m;
  352. {
  353.     Output("()");
  354.     return( m + 2 );
  355. }
  356.  
  357. Object Empty_List_GC(old)
  358.  
  359.     Object old;
  360. {
  361.     Object new = Move_Object(old, Empty_List_Size);
  362.  
  363.     return new;
  364. }
  365.  
  366. /* Symbol */
  367.  
  368. Op_Vector Symbol_Ops = {
  369.     Self_Eval, Compile_Symbol, Symbol_Print, Symbol_Print, Symbol_Print,
  370.         Symbol_GC};
  371.  
  372. Scheme_Type Symbol_Type = &Symbol_Ops;
  373.  
  374. Public    Object    QUOTE_Symbol, DEFINE_Symbol, SET_Symbol, 
  375.         IF_Symbol, MACRO_Symbol,
  376.         BEGIN_Symbol, DELAY_Symbol, LAMBDA_Symbol;
  377.  
  378. Public    Object    The_Syntactic_Keyword, The_Undefined_Symbol, An_Argument;
  379.  
  380. Private Object Special_Symbol( Representation )
  381.  
  382.     String    Representation;
  383. {
  384.     Object    new = Intern_Name( Representation );
  385.  
  386.     Get_Global_Binding( new ) = The_Syntactic_Keyword;
  387.     return( new );
  388. }
  389.  
  390.  
  391. Private void Init_Symbol()
  392. {
  393.     Make_Symbol("<undefined symbol>");
  394.     The_Undefined_Symbol = Value_Register;
  395.     Get_Global_Binding(The_Undefined_Symbol) = The_Undefined_Symbol;
  396.  
  397.     Make_Symbol("<special symbol binding object>");
  398.     The_Syntactic_Keyword = Value_Register;
  399.     Get_Global_Binding(The_Syntactic_Keyword) = NULL;
  400.  
  401.     Make_Symbol( "<an argument>" );
  402.     An_Argument = Value_Register;
  403.     Get_Global_Binding( An_Argument ) = An_Argument;
  404.  
  405.     QUOTE_Symbol = Special_Symbol( "quote" );
  406.     DEFINE_Symbol = Special_Symbol( "define" );
  407.     SET_Symbol = Special_Symbol( "set!" );
  408.     IF_Symbol = Special_Symbol( "if" );
  409.     MACRO_Symbol = Special_Symbol( "macro" );
  410.     BEGIN_Symbol = Special_Symbol( "begin" );
  411.     DELAY_Symbol = Special_Symbol( "delay" );
  412.     LAMBDA_Symbol = Special_Symbol( "lambda" );
  413.  
  414. }
  415.  
  416. Public    void Make_Symbol(name)
  417.  
  418.     String name;
  419. {
  420.     String Copy_String();
  421.  
  422.     Value_Register = Allocate(Symbol_Size);
  423.  
  424.     Get_Symbol_Name(Value_Register) = Copy_String(name);
  425.     Get_Property_List(Value_Register) = Nil;
  426.     Get_Global_Binding(Value_Register) = The_Undefined_Symbol;
  427.     Get_Symbol_How(Value_Register) = The_Undefined_Symbol;
  428.     Get_Symbol_User_Defined(Value_Register) = FALSE;
  429.  
  430.     Set_Result_Type(Symbol_Type);
  431. }
  432.  
  433. Public    Integer    Symbol_Print( o , m )  /* Assumes no nulls in name */
  434.  
  435.     Object    o;
  436.     Integer    m;
  437. {
  438.     Output( Get_Symbol_Name(o) );
  439.     return( m + strlen( Get_Symbol_Name(o) ) );
  440. }
  441.  
  442. Public Object Symbol_GC(old)
  443.  
  444.     Object old;
  445. {
  446.     Object new = Move_Object(old, Symbol_Size);
  447.  
  448.     Relocate(&Get_Global_Binding(new));
  449.     Relocate(&Get_Symbol_How(new));
  450.     Relocate(&Get_Property_List(new));
  451.     return new;
  452. }
  453.  
  454. /* Numbers. */
  455.  
  456. Op_Vector Number_Ops = {
  457.     Self_Eval, Self_Compile, Number_Print,
  458.         Number_Print, Number_Print,  Number_GC};
  459.  
  460. Scheme_Type Number_Type = &Number_Ops;
  461.  
  462. Public void Make_Fixnum_Number(n)
  463.  
  464.     Short n;
  465. {
  466.     Value_Register = Allocate( Fixnum_Size );
  467.  
  468.     Get_Number_Tower_Position(Value_Register) = FIXNUM_LEVEL;
  469.     Get_Number_Fixnum_Value(Value_Register) = n;
  470.     Is_Exact_Number(Value_Register) = TRUE;
  471.  
  472.     Set_Result_Type(Number_Type);
  473. }
  474.  
  475.  
  476. Public    void Make_Bignum_Number(length)
  477.  
  478.     Integer length;
  479. {
  480.     Integer this_digit;
  481.  
  482.     Value_Register = Allocate(Bignum_Size(length));
  483.  
  484.     Get_Number_Tower_Position(Value_Register) = BIGNUM_LEVEL;
  485.     Get_Number_Length(Value_Register) = length;
  486.     Is_Exact_Number(Value_Register) = TRUE;
  487.  
  488.     for (this_digit = 0; this_digit < length; this_digit++)
  489.     {
  490.         Get_Number_Digits(Value_Register)[this_digit] = 0;
  491.     }
  492.  
  493.     Set_Result_Type(Number_Type);
  494. }
  495.  
  496. Public void Make_Rational_Number()
  497. {
  498.     Import     void Reduce_Rational();
  499.     Boolean    exact = Is_Exact_Number(Top(1)) && Is_Exact_Number(Top(2));
  500.  
  501.     /* Represent Numerator and Denominator by exacts */
  502.  
  503.     if ( ! Is_Exact_Number( Top(1) ) )
  504.     {
  505.         Push( Top(1) );
  506.         Number_Inexact_To_Exact(); Pop(1);
  507.         Replace( 1 , Value_Register );
  508.     }
  509.  
  510.     if ( ! Is_Exact_Number( Top(2) ) )
  511.     {
  512.         Push( Top(2) );
  513.         Number_Inexact_To_Exact(); Pop(1);
  514.         Replace( 2 , Value_Register );
  515.     }
  516.  
  517.     /* Check for zero Denominator */
  518.  
  519.     Push( Top(1) );
  520.     Is_Number_Zero(); 
  521.     Pop(1);
  522.     if ( Value_Register == The_True_Object )
  523.     {
  524.         Error( "Division by Zero" );
  525.     }
  526.  
  527.     /* All rationals have a non-negative Denominator */
  528.     
  529.     Push( Top(1) );
  530.     Is_Number_Negative();
  531.     Pop(1);
  532.  
  533.     if (Value_Register == The_True_Object)
  534.     {
  535.         Push( Top( 1 ) );
  536.         Number_Negate();
  537.         Pop(1);
  538.         Replace(1, Value_Register);
  539.         Push(Top(2));
  540.         Number_Negate();
  541.         Pop(1);
  542.         Replace(2, Value_Register);
  543.     }
  544.     
  545.     Value_Register = Allocate(Rational_Size);
  546.  
  547.     Get_Number_Tower_Position(Value_Register) = RATIONAL_LEVEL;
  548.     Get_Number_Rational_Numerator(Value_Register) = Top(2);
  549.     Get_Number_Rational_Denominator(Value_Register) = Top(1);
  550.     Is_Exact_Number(Value_Register) = exact;
  551.  
  552.     Set_Result_Type(Number_Type);
  553.     Reduce_Rational();
  554. }
  555.  
  556. Public void Make_Real_Number(r)
  557.  
  558.     Double r;
  559. {
  560.     Value_Register = Allocate(Real_Size);
  561.  
  562.     Get_Number_Tower_Position(Value_Register) = REAL_LEVEL;
  563.     Get_Number_Real_Value(Value_Register) = r;
  564.     Is_Exact_Number(Value_Register) = FALSE;
  565.  
  566.     Set_Result_Type(Number_Type);
  567. }
  568.  
  569. Public void Make_Complex_Number(r,i)
  570.  
  571.     Double r,i;
  572. {
  573.     Value_Register = Allocate(Complex_Size);
  574.  
  575.     Get_Number_Tower_Position(Value_Register) = COMPLEX_LEVEL;
  576.     Get_Number_Complex_Real_Part(Value_Register) = r;
  577.     Get_Number_Complex_Imaginary_Part(Value_Register) = i;
  578.     Is_Exact_Number(Value_Register) = FALSE;
  579.  
  580.     Set_Result_Type(Number_Type);
  581. }
  582.  
  583.  
  584. Public Integer    Number_Print(o, m)
  585.  
  586.     Object    o;
  587.     Integer m;
  588. {
  589.     Push( Value_Register );                /* Save it */
  590.  
  591.     Push(o);
  592.     Integer_To_Number( 10 );
  593.     Push( Value_Register );
  594.     Number_To_String(); Pop(2);
  595.     Output(Get_String_Value(Value_Register));
  596.     m += Get_String_Length( Value_Register );
  597.  
  598.     Value_Register = Top(1);            /* Restore it */
  599.     Pop(1);
  600.  
  601.     return( m );
  602. }
  603.  
  604. Public Object Number_GC(old)
  605.  
  606.     Object old;
  607. {
  608.     Object new;
  609.  
  610.     switch ( Get_Number_Tower_Position(old) )
  611.     {
  612.         case FIXNUM_LEVEL:
  613.         new = Move_Object(old, Fixnum_Size);
  614.         break;
  615.         case BIGNUM_LEVEL:
  616.         new = Move_Object(old, Bignum_Size(Get_Number_Length(old)));
  617.         break;
  618.         case RATIONAL_LEVEL:
  619.         new = Move_Object(old, Rational_Size);
  620.         Relocate( &Get_Number_Rational_Numerator(new) );
  621.         Relocate( &Get_Number_Rational_Denominator(new) );
  622.         break;
  623.         case REAL_LEVEL:
  624.         new = Move_Object(old, Real_Size);
  625.         break;
  626.         case COMPLEX_LEVEL:
  627.         new = Move_Object(old, Complex_Size);
  628.         break;
  629.         default:
  630.         new = Nil ;
  631.         Panic("I'm trying to garbage collect an unimplemented number");
  632.     }
  633.  
  634.     return new;
  635. }
  636.  
  637.  
  638. /* Character. */
  639.  
  640. Op_Vector Character_Ops = { Self_Eval, Self_Compile,
  641.     Character_Display, Character_Write, Character_Write, Character_GC};
  642.  
  643. Scheme_Type Character_Type = &Character_Ops;
  644.  
  645. Public void Make_Character(c)
  646.  
  647.     Character c;
  648. {
  649.     Value_Register = Allocate(Character_Size);
  650.     Get_Character_Value(Value_Register) = c;
  651.  
  652.     Set_Result_Type(Character_Type);
  653. }
  654.  
  655. Public Integer Character_Write( o, m )
  656.  
  657.     Object    o;
  658.     Integer    m;
  659. {
  660.     Output("#\\"); m += 2;
  661.  
  662.     if (Get_Character_Value(o) == ' ')
  663.     {
  664.         Output("space"); m += 5;
  665.     }
  666.     else if (Get_Character_Value(o) == '\n')
  667.     {
  668.         Output("newline"); m += 7;
  669.     }
  670.     else
  671.     {
  672.         Output_Char(Get_Character_Value(o)); m += 1;
  673.     }
  674.  
  675.     Output(" "); m += 1;
  676.  
  677.     return( m );
  678. }
  679.  
  680. Public Integer Character_Display( o, m )
  681.  
  682.     Object    o;
  683.     Integer    m;
  684. {
  685.     Output_Char(Get_Character_Value(o));
  686.     return( m + 1 );
  687. }
  688.  
  689. Public Object Character_GC(old)
  690.  
  691.     Object old;
  692. {
  693.     Object new = Move_Object(old, Character_Size);
  694.  
  695.     return new;
  696. }
  697.  
  698. /* String. */
  699.  
  700. Op_Vector String_Ops = {
  701.     Self_Eval, Self_Compile, String_Display,
  702.         String_Write, String_Write, String_GC};
  703.  
  704. Scheme_Type String_Type = &String_Ops;
  705.  
  706. Public void Make_String(l)
  707.  
  708.     Integer l;
  709. {
  710.     Value_Register = Allocate(String_Size(l+1));
  711.     Get_String_Length(Value_Register) = l;
  712.  
  713.     Set_Result_Type(String_Type);
  714. }
  715.  
  716. Public void Make_Constant_String(s)
  717.  
  718.     String s;
  719. {
  720.     Value_Register = Allocate(String_Size(strlen(s)+1));
  721.     Get_String_Length(Value_Register) = strlen(s);
  722.     strcpy(Get_String_Value(Value_Register),s);
  723.  
  724.     Set_Result_Type(String_Type);
  725. }
  726.  
  727. Public String Copy_String(str)
  728.  
  729.     String str;
  730. {
  731.     String answer = (String)malloc(strlen(str) + 1);
  732.  
  733.     if (answer == NULL)
  734.         Panic("I ran out of memory in Copy_String");
  735.  
  736.     strcpy(answer, str);
  737.     return answer;
  738. }
  739.  
  740. Public Integer String_Write( o, m )
  741.  
  742.     Object    o;
  743.     Integer    m;
  744. {
  745.     Integer this_char;
  746.  
  747.     Output("\""); m += 1;
  748.  
  749.     for (this_char = 0; this_char < Get_String_Length(o); this_char++)
  750.     {
  751.         if (Get_String_Value(o)[this_char] == '\"')
  752.         {
  753.             Output("\\\""); m += 2;
  754.         }
  755.         else if (Get_String_Value(o)[this_char] == '\\')
  756.         {
  757.             Output("\\"); m += 1;
  758.         }
  759.         else
  760.         {
  761.             Output_Char(Get_String_Value(o)[this_char]); m += 1;
  762.         }
  763.     }
  764.  
  765.     Output("\""); m += 1;
  766.     return( m );
  767. }
  768.  
  769. Public    Integer    String_Display( o , m )
  770.  
  771.     Object    o;
  772.     Integer    m;
  773. {
  774.     Integer this_char;
  775.  
  776.     for (this_char = 0; this_char < Get_String_Length(o); this_char++)
  777.     {
  778.         Output_Char(Get_String_Value(o)[this_char]); 
  779.     }
  780.     return( m + Get_String_Length(o)  );
  781. }
  782.  
  783. Public Object String_GC(old)
  784.  
  785.     Object old;
  786. {
  787.     Object new = Move_Object(old, String_Size(Get_String_Length(old)));
  788.  
  789.     return new;
  790. }
  791.  
  792.  
  793. /* Vector. */
  794.  
  795. Op_Vector Vector_Ops = {
  796.     Self_Eval, Self_Compile, Vector_Display,
  797.         Vector_Write, Vector_Show,  Vector_GC};
  798.  
  799. Scheme_Type Vector_Type = &Vector_Ops;
  800.  
  801. Public void Make_Vector(length)
  802.  
  803.     Integer length;
  804. {
  805.     Value_Register = Allocate(Vector_Size(length));
  806.     Get_Vector_Length(Value_Register) = length;
  807.  
  808.     while (length--)
  809.     {
  810.         Get_Vector_Elem(Value_Register, length) = The_Undefined_Symbol;
  811.     }
  812.  
  813.     Set_Result_Type(Vector_Type);
  814. }
  815.  
  816. Public    Integer    Vector_Display( o, m )
  817.  
  818.     Object    o;
  819.     Integer    m;
  820. {
  821.     Integer this_element;
  822.  
  823.     Output("#("); m += 3;
  824.  
  825.     for (this_element = 0; this_element < Get_Vector_Length(o); 
  826.          this_element++)
  827.     {
  828.         if ( this_element )
  829.         {
  830.             Output(" "); m += 1;
  831.         }
  832.         m = Display_Object( Get_Vector_Elem(o, this_element) , m );
  833.     }
  834.  
  835.     Output(")"); m += 1;
  836.     return( m );
  837. }
  838.  
  839. Public    Integer    Vector_Write( o, m )
  840.  
  841.     Object    o;
  842.     Integer    m;
  843. {
  844.     Integer this_element;
  845.  
  846.     Output("#("); m += 3;
  847.  
  848.     for (this_element = 0; this_element < Get_Vector_Length(o); 
  849.          this_element++)
  850.     {
  851.         if ( this_element )
  852.         {
  853.             Output(" "); m += 1;
  854.         }
  855.         m = Write_Object( Get_Vector_Elem(o, this_element) , m );
  856.     }
  857.  
  858.     Output(")"); m += 1;
  859.     return( m );
  860. }
  861.  
  862.  
  863. Public    Integer    Vector_Show( o, m )
  864.  
  865.     Object    o;
  866.     Integer    m;
  867. {
  868.     Integer this_element;
  869.     Integer length = Get_Vector_Length(o);
  870.  
  871.     Output("#("); m += 2;
  872.  
  873.     if  (length > 3)
  874.     {
  875.         m = Write_Object( Get_Vector_Elem(o,0) , m ) + 1; Output( " " );
  876.         m = Write_Object( Get_Vector_Elem(o,1) , m ) + 1; Output( " " );
  877.         m = Write_Object( Get_Vector_Elem(o,2) , m ) + 1; Output( " " );
  878.         Output( "...)" ); m += 4;
  879.     }
  880.     else
  881.     {
  882.         for (this_element = 0; this_element < length; this_element++)
  883.         {
  884.             m = Write_Object(Get_Vector_Elem(o,this_element),m) + 1;
  885.             Output( this_element == (length-1) ? ")" : " " );
  886.         }
  887.     }
  888.  
  889.     return( m );
  890. }
  891.  
  892.  
  893. Public Object Vector_GC(old)
  894.  
  895.     Object old;
  896. {
  897.     Object new = Move_Object(old, Vector_Size(Get_Vector_Length(old)));
  898.     Integer this_element;
  899.  
  900.     for (this_element = 0; this_element < Get_Vector_Length(old); 
  901.          this_element++)
  902.     {
  903.         Relocate(&Get_Vector_Elem(new,this_element));
  904.     }
  905.  
  906.     return new;
  907. }
  908.  
  909.  
  910. /* Procedure. */
  911.  
  912. Op_Vector Procedure_Ops = {
  913.     Self_Eval, Self_Compile,
  914.         Procedure_Print, Procedure_Print, Procedure_Show, Procedure_GC};
  915.  
  916. Scheme_Type Procedure_Type = &Procedure_Ops;
  917.  
  918. Public void Make_Procedure()
  919. {
  920.     Object lambda;
  921.  
  922.     Value_Register = Allocate(Procedure_Size);
  923.  
  924.     lambda = Top(1);
  925.     Get_Procedure_Name(Value_Register) = "<Anonymous>";
  926.     Get_Procedure_Numargs(Value_Register) = Get_Lambda_Numargs(lambda);
  927.     Get_Procedure_Tracing(Value_Register) = FALSE;
  928.     Get_Procedure_Has_Rest(Value_Register) =
  929.         Get_Lambda_Has_Rest(lambda);
  930.     Get_Procedure_Body(Value_Register) = Get_Lambda_Body(lambda);
  931.     Get_Procedure_Frame(Value_Register) = Get_Lambda_Frame(lambda);
  932.     Get_Procedure_Environment(Value_Register) = Environment_Register;
  933.  
  934.     Set_Result_Type(Procedure_Type);
  935.     Pop(1);
  936. }
  937.  
  938. Public    Integer    Procedure_Print( o, m )
  939.  
  940.     Object    o;
  941.     Integer    m;
  942. {
  943.     Integer in_m = m;
  944.  
  945.     Output( "(lambda " ); m +=  8;
  946.     m = Write_Object( Get_Procedure_Frame(o) , m );
  947.  
  948.     m = Write_Object( Get_Procedure_Body(o) , in_m ); /* Prints `)' */
  949.  
  950.     return( m );
  951. }
  952.  
  953.  
  954.  
  955. Public    Integer    Procedure_Show( o , m )
  956.  
  957.     Object    o;
  958.     Integer    m;
  959. {
  960.     Output("(lambda "); m += 8;
  961.     m = Write_Object( Get_Procedure_Frame(o) , m );
  962.     Output("  ...)"); m += 5;
  963.     return( m );
  964. }
  965.  
  966. Public Object Procedure_GC(old)
  967.  
  968.     Object old;
  969. {
  970.     Object new = Move_Object(old, Procedure_Size);
  971.  
  972.     Relocate(&Get_Procedure_Body(new));
  973.     Relocate(&Get_Procedure_Environment(new));
  974.     Relocate(&Get_Procedure_Frame(new));
  975.  
  976.     return new;
  977.  
  978. }
  979.  
  980. /* Primitive. (Scheme procedures implemented in C.) */
  981.  
  982. Op_Vector Primitive_Ops = {
  983.     Self_Eval, Self_Compile, Primitive_Print,
  984.         Primitive_Print, Primitive_Print,  Primitive_GC};
  985.  
  986. Scheme_Type Primitive_Type = &Primitive_Ops;
  987.  
  988. Public void Make_Primitive(name, proc, arg_count, arg_type1, 
  989.               arg_type2, arg_type3)
  990.     String name;
  991.     void (*proc)();
  992.     Integer arg_count;
  993.     Scheme_Type arg_type1, arg_type2, arg_type3;
  994. {
  995.     Object Interned_Symbol;
  996.  
  997.     Value_Register = Allocate(Primitive_Size(arg_count));
  998.     Get_Primitive_Name(Value_Register) = name;
  999.     Get_Primitive_Procedure(Value_Register) = proc;
  1000.     Get_Primitive_Numargs(Value_Register) = arg_count;
  1001.     Get_Primitive_Tracing(Value_Register) = FALSE;
  1002.  
  1003.     switch (arg_count)
  1004.     {
  1005.     case 3:
  1006.         Get_Primitive_Argtypes(Value_Register,2) = arg_type3;
  1007.     case 2:
  1008.         Get_Primitive_Argtypes(Value_Register,1) = arg_type2;
  1009.     case 1:
  1010.     case VARYING:
  1011.         Get_Primitive_Argtypes(Value_Register,0) = arg_type1;
  1012.         break;
  1013.     case 0:
  1014.         break;
  1015.     default:
  1016.         Panic("I thought all primitives had fewer than four types");
  1017.     }
  1018.  
  1019.     Set_Result_Type(Primitive_Type);
  1020.     Push( Value_Register );  /* Save Primitive */
  1021.  
  1022.     /* Put the name in our hash table. */
  1023.     Interned_Symbol = Intern_Name(name);
  1024.  
  1025.     Value_Register = Top(1);
  1026.     Pop(1);            /* Restore Primitive from stack */
  1027.     /* Put the thing we just made in the global environment. */
  1028.     Get_Global_Binding( Interned_Symbol ) = Value_Register ;
  1029. }
  1030.  
  1031. Public    Integer    Primitive_Print( o , m )
  1032.  
  1033.     Object    o;
  1034.     Integer    m;
  1035. {
  1036.     Integer this_type;
  1037.  
  1038.     Output("< primitive: ");
  1039.  
  1040.     Output(Get_Primitive_Name(o));
  1041.     Output(" ");
  1042.     if ( Get_Primitive_Numargs(o) == VARYING )
  1043.     {
  1044.         Print_Type(Get_Primitive_Argtypes(o,0));
  1045.         Output( "... " );
  1046.     }
  1047.     else
  1048.     {
  1049.         for (this_type=0; this_type<Get_Primitive_Numargs(o); 
  1050.             this_type++)
  1051.         {
  1052.             Print_Type(Get_Primitive_Argtypes(o,this_type));
  1053.             Output(" ");
  1054.         }
  1055.     }
  1056.  
  1057.     Output(">");
  1058.     return( 0 );
  1059. }
  1060.  
  1061. Public Object Primitive_GC(old)
  1062.  
  1063.     Object old;
  1064. {
  1065.     Object new = Move_Object(old, Primitive_Size(Get_Primitive_Numargs(old)));
  1066.  
  1067.     return new;
  1068. }
  1069.  
  1070. /* Continuation. */
  1071.  
  1072. Op_Vector Continuation_Ops = {
  1073.     Self_Eval, Self_Compile,
  1074.         Continuation_Print, Continuation_Print, Continuation_Print,
  1075.         Continuation_GC};
  1076.  
  1077. Scheme_Type Continuation_Type = &Continuation_Ops;
  1078.  
  1079. Public void Make_Continuation()
  1080. {
  1081.     Integer this_element;
  1082.     Value_Register = Allocate(Continuation_Size(Arg_Stack_Ptr));
  1083.  
  1084.     Get_Continuation_State(Value_Register) = State_Register;
  1085.     Get_Continuation_Stacksize(Value_Register) = Arg_Stack_Ptr;
  1086.  
  1087.     for (this_element = 0; this_element < Arg_Stack_Ptr; this_element++)
  1088.     {
  1089.         Get_Continuation_Stack_Elem(Value_Register,this_element) =
  1090.             Arg_Stack[this_element];
  1091.     }
  1092.  
  1093.     Set_Result_Type(Continuation_Type);
  1094. }
  1095.  
  1096. Public    Integer    Continuation_Print( o , m )
  1097.  
  1098.     Object    o;
  1099.     Integer    m;
  1100. {
  1101.     Output("<continuation>");
  1102.     return( m + 14 );
  1103. }
  1104.  
  1105. Public Object Continuation_GC(old)
  1106.  
  1107.     Object old;
  1108. {
  1109.     Integer this_element;
  1110.     Object new = Move_Object(old, 
  1111.         Continuation_Size(Get_Continuation_Stacksize(old)));
  1112.  
  1113.     Relocate(&Get_Continuation_State(new));
  1114.     for (this_element = 0; this_element < Get_Continuation_Stacksize(new);
  1115.         this_element++)
  1116.     {
  1117.         Relocate(&Get_Continuation_Stack_Elem(new,this_element));
  1118.     }
  1119.  
  1120.     return new;
  1121. }
  1122.  
  1123. /* Port. */
  1124.  
  1125. Op_Vector Port_Ops = { Self_Eval, Self_Compile, 
  1126.             Port_Print, Port_Print, Port_Print, Port_GC};
  1127.  
  1128. Scheme_Type Port_Type = &Port_Ops;
  1129.  
  1130. Public Object Current_Input_Port, Current_Output_Port, The_Transcript_Port;
  1131.  
  1132. Private void Init_Port()
  1133. {
  1134.     The_Standard_Input = stdin;
  1135.     The_Standard_Output = stdout;
  1136.  
  1137.     Make_Port(TRUE, The_Standard_Input, "stdin");
  1138.     Current_Input_Port = Value_Register;
  1139.  
  1140.     Make_Port(FALSE, The_Standard_Output, "stdout");
  1141.     Current_Output_Port = Value_Register;
  1142.  
  1143.     The_Transcript_Port = Nil;
  1144. }
  1145.  
  1146. Public void Make_Port(is_input, file, filename)
  1147.  
  1148.     Boolean is_input;
  1149.     FILE *file;
  1150.     String filename;
  1151. {
  1152.     Value_Register = Allocate(Port_Size);
  1153.     Is_Input_Port(Value_Register) = is_input;
  1154.     Get_Port_File(Value_Register) = file;
  1155.     Get_Port_Name(Value_Register) = Copy_String(filename);
  1156.  
  1157.     Set_Result_Type(Port_Type);
  1158. }
  1159.  
  1160. Public    Integer    Port_Print( o, m )
  1161.  
  1162.     Object    o;
  1163.     Integer    m;
  1164. {
  1165.     if (Is_Input_Port(o))
  1166.     {
  1167.         Output("<input port connected to `"); m += 26;
  1168.     }
  1169.     else
  1170.     {
  1171.         Output("<output port connected to `"); m += 27;
  1172.     }
  1173.  
  1174.     if (Get_Port_Name(o) != NULL)
  1175.     {
  1176.         Output( Get_Port_Name(o) ); m += strlen( Get_Port_Name(o) );
  1177.     }
  1178.  
  1179.     Output("'>"); m += 2;
  1180.     return( m );
  1181. }
  1182.  
  1183. Public Object Port_GC(old)
  1184.  
  1185.     Object old;
  1186. {
  1187.     Object new = Move_Object(old, Port_Size);
  1188.  
  1189.     return new;
  1190. }
  1191.  
  1192. /* End-of-file. */
  1193.  
  1194. Op_Vector Eof_Ops = {
  1195.     Self_Eval, Self_Compile, Eof_Display, Eof_Write, Eof_Display,  Eof_GC};
  1196.  
  1197. Scheme_Type Eof_Type = &Eof_Ops;
  1198.  
  1199. Public Object The_Eof_Object;
  1200.  
  1201. Private void Init_Eof()
  1202. {
  1203.     The_Eof_Object = Allocate(Eof_Size);
  1204.  
  1205.     Get_Type(The_Eof_Object) = Eof_Type;
  1206.     Get_Type_Name(The_Eof_Object) = "Eof_Type";
  1207. }
  1208.  
  1209. Public    Integer    Eof_Write( o, m )
  1210.  
  1211.     Object    o;
  1212.     Integer    m;
  1213. {
  1214.     Output_Char('\004');
  1215.     return( m + 1 );
  1216. }
  1217.  
  1218. Public    Integer    Eof_Display( o , m )
  1219.  
  1220.     Object    o;
  1221.     Integer    m;
  1222. {
  1223.     Output("<eof>");
  1224.     return( m + 5 );
  1225. }
  1226.  
  1227. Public    Object    Eof_GC( old )
  1228.  
  1229.     Object old;
  1230. {
  1231.     Object new = Move_Object( old, Eof_Size );
  1232.  
  1233.     return new;
  1234. }
  1235.  
  1236. /* Variable  (lexically addressed by frame and displacement) */
  1237.  
  1238. Op_Vector Variable_Ops = {
  1239.     Variable_Eval, Self_Compile, Variable_Print,
  1240.         Variable_Print, Variable_Print, Variable_GC};
  1241.  
  1242. Scheme_Type Variable_Type = &Variable_Ops;
  1243.  
  1244. Public void Make_Local_Variable(symbol, frame, displacement)
  1245.  
  1246.     Object    symbol;
  1247.     Integer frame;
  1248.     Integer displacement;
  1249. {
  1250.     Value_Register = Allocate(Variable_Size);
  1251.  
  1252.     if (! Is_Symbol(symbol))
  1253.         Panic("Expected a symbol in Make_Variable_Local");
  1254.  
  1255.     Is_Local_Variable(Value_Register) = TRUE;
  1256.     Get_Variable_Frame_Number(Value_Register) = frame;
  1257.     Get_Variable_Displacement(Value_Register) = displacement;
  1258.     Get_Variable_Symbol(Value_Register) = symbol;
  1259.  
  1260.     Set_Result_Type(Variable_Type);
  1261. }
  1262.  
  1263.  
  1264.  
  1265. Public void Make_Global_Variable( symbol )
  1266.  
  1267.     Object    symbol;
  1268. {
  1269.     Value_Register = Allocate(Variable_Size);
  1270.  
  1271.     if (! Is_Symbol(symbol))
  1272.         Panic("Expected a symbol in Make_Variable_Global");
  1273.  
  1274.     Is_Local_Variable(Value_Register) = FALSE;
  1275.     Get_Variable_Symbol(Value_Register) = symbol;
  1276.  
  1277.     Set_Result_Type(Variable_Type);
  1278. }
  1279.  
  1280. Public    Integer    Variable_Print( o, m )
  1281.  
  1282.     Object    o;
  1283.     Integer    m;
  1284. {
  1285.     return( Symbol_Print( Get_Variable_Symbol(o), m ) );
  1286. }
  1287.  
  1288. Public Object Variable_GC(old)
  1289.  
  1290.     Object old;
  1291. {
  1292.     Object new = Move_Object(old, Variable_Size);
  1293.  
  1294.     Relocate(&Get_Variable_Symbol(new));
  1295.  
  1296.     return new;
  1297. }
  1298.  
  1299. /* Apply. */
  1300.  
  1301. Op_Vector Apply_Ops = {
  1302.     Apply_Eval, Self_Compile, Apply_Print, Apply_Print,
  1303.     Apply_Print,  Apply_GC};
  1304.  
  1305. Scheme_Type Apply_Type = &Apply_Ops;
  1306.  
  1307. Public void Make_Apply()
  1308. {
  1309.     Value_Register = Allocate(Apply_Size);
  1310.     Get_Apply_Numargs(Value_Register) = Length(Top(1));
  1311.     Get_Apply_Arguments(Value_Register) = Top(1);
  1312.     Get_Apply_Operator(Value_Register) = Top(2);
  1313.  
  1314.     Set_Result_Type(Apply_Type);
  1315.     Pop(2);
  1316. }
  1317.  
  1318. Public    Integer    Apply_Print( o , m )
  1319.  
  1320.     Object    o;
  1321.     Integer    m;
  1322. {
  1323.     Output("("); m += 1;
  1324.  
  1325.     m = Write_Object( Get_Apply_Operator(o), m );
  1326.  
  1327.     o = Get_Apply_Arguments(o);
  1328.  
  1329.     while ( Is_Pair( o ) )
  1330.     {
  1331.         Output( " " ); m += 1;
  1332.         m = Write_Object( Get_Pair_Car( o ) , m );
  1333.         o = Get_Pair_Cdr( o );
  1334.     }
  1335.     Output( ")" ); m += 1;
  1336.  
  1337.     return( m );
  1338. }
  1339.  
  1340. Public Object Apply_GC(old)
  1341.  
  1342.     Object old;
  1343. {
  1344.     Object new = Move_Object(old, Apply_Size);
  1345.  
  1346.     Relocate(&Get_Apply_Operator(new));
  1347.     Relocate(&Get_Apply_Arguments(new));
  1348.  
  1349.     return new;
  1350. }
  1351.  
  1352. /* Lambda  */
  1353.  
  1354. Op_Vector Lambda_Ops = {
  1355.     Lambda_Eval, Self_Compile, Lambda_Print,
  1356.         Lambda_Print, Lambda_Print,  Lambda_GC};
  1357.  
  1358. Scheme_Type Lambda_Type = &Lambda_Ops;
  1359.  
  1360. #define Save_Lambda_Objects() \
  1361.     {Push(formals); Push(body); Push(rest); Push(frame);}
  1362.  
  1363. #define Restore_Lambda_Objects() \
  1364.     { frame = Top(1); rest = Top(2); body = Top(3); formals = Top(4); \
  1365.           Pop(4); }
  1366.  
  1367.  
  1368. Public void Make_Lambda()
  1369. {
  1370.     Object frame;
  1371.     Object body;
  1372.  
  1373.     Value_Register = Allocate(Lambda_Size);
  1374.     frame = Top(2);
  1375.     body = Top(1);
  1376.     Get_Lambda_Numargs(Value_Register) = 
  1377.         Get_Environment_Frame_Size(frame) -
  1378.             (Get_Environment_Frame_Has_Rest(frame) ? 1 : 0);
  1379.     Get_Lambda_Has_Rest(Value_Register) =
  1380.         Get_Environment_Frame_Has_Rest(frame);
  1381.     Get_Lambda_Frame(Value_Register) = frame;
  1382.     Get_Lambda_Body(Value_Register) = body;
  1383.  
  1384.     Set_Result_Type(Lambda_Type);
  1385.     Pop(2);
  1386. }
  1387.  
  1388. Public    Integer    Lambda_Print( o, m )
  1389.  
  1390.     Object    o;
  1391.     Integer    m;
  1392. {
  1393.     Integer in_m = m;
  1394.  
  1395.     Output( "(lambda " ); m +=  8;
  1396.     m = Write_Object( Get_Lambda_Frame(o) , m );
  1397.  
  1398.     m = Write_Object( Get_Lambda_Body(o) , in_m ); /* Prints closing `)' */
  1399.  
  1400.     return( m );
  1401. }
  1402.  
  1403. Public Object Lambda_GC(old)
  1404.  
  1405.     Object old;
  1406. {
  1407.     Object new = Move_Object(old, Lambda_Size);
  1408.  
  1409.     Relocate(&Get_Lambda_Frame(new));
  1410.     Relocate(&Get_Lambda_Body(new));
  1411.  
  1412.     return new;
  1413. }
  1414.  
  1415.  
  1416. /* Conditional. */
  1417.  
  1418. Op_Vector Conditional_Ops = {
  1419.     Conditional_Eval, Self_Compile,
  1420.         Conditional_Print, Conditional_Print, Conditional_Print,
  1421.         Conditional_GC};
  1422.  
  1423. Scheme_Type Conditional_Type = &Conditional_Ops;
  1424.  
  1425. /* make-conditional test consequent alternate. */
  1426. Public void Make_Conditional()
  1427. {
  1428.     Value_Register = Allocate(Conditional_Size);
  1429.     Get_Conditional_Test(Value_Register) = Top(3);
  1430.     Get_Conditional_Consequent(Value_Register) = Top(2);
  1431.     Get_Conditional_Alternate(Value_Register) = Top(1);
  1432.  
  1433.     Set_Result_Type(Conditional_Type);
  1434.     Pop(3);
  1435. }
  1436.  
  1437. Public    Integer    Conditional_Print( o , m )
  1438.  
  1439.     Object    o;
  1440.     Integer    m;
  1441. {
  1442.     Integer    in_m = m;
  1443.  
  1444.     Output("(if "); m += 4;
  1445.  
  1446.     m = Write_Object( Get_Conditional_Test(o) , m );
  1447.  
  1448.     m = New_Left_Margin( in_m + INDENT );
  1449.     m = Write_Object( Get_Conditional_Consequent(o), m );
  1450.  
  1451.     m = New_Left_Margin( in_m + INDENT );
  1452.     m = Write_Object( Get_Conditional_Alternate(o) , m );
  1453.  
  1454.     Output(")"); m += 1;
  1455.     
  1456.     return( m );
  1457. }
  1458.  
  1459. Public Object Conditional_GC(old)
  1460.  
  1461.     Object old;
  1462. {
  1463.     Object new = Move_Object(old, Conditional_Size);
  1464.  
  1465.     Relocate(&Get_Conditional_Test(new));
  1466.     Relocate(&Get_Conditional_Consequent(new));
  1467.     Relocate(&Get_Conditional_Alternate(new));
  1468.  
  1469.     return new;
  1470. }
  1471.  
  1472.  
  1473. /* Assignment */
  1474.  
  1475. Op_Vector Assignment_Ops = {
  1476.     Assignment_Eval, Self_Compile,
  1477.         Assignment_Print, Assignment_Print, Assignment_Print,
  1478.         Assignment_GC};
  1479.  
  1480. Scheme_Type Assignment_Type = &Assignment_Ops;
  1481.  
  1482. Public void Make_Assignment()
  1483. {
  1484.     Value_Register = Allocate(Assignment_Size);
  1485.     Get_Assignment_Lvalue(Value_Register) = Top(2);
  1486.     Get_Assignment_Rvalue(Value_Register) = Top(1);
  1487.  
  1488.     Set_Result_Type(Assignment_Type);
  1489.     Pop(2);
  1490. }
  1491.  
  1492. Public    Integer    Assignment_Print( o, m )
  1493.  
  1494.     Object    o;
  1495.     Integer    m;
  1496. {
  1497.     Output( "(set! " ); m += 6;
  1498.  
  1499.     m = Write_Object( Get_Assignment_Lvalue(o), m );
  1500.  
  1501.     Output(" "); m += 1;
  1502.  
  1503.     m = Write_Object( Get_Assignment_Rvalue(o) , m );
  1504.  
  1505.     Output( ")" ); m += 1;
  1506.     return( m );
  1507. }
  1508.  
  1509. Public Object Assignment_GC(old)
  1510.  
  1511.     Object old;
  1512. {
  1513.     Object new = Move_Object(old, Assignment_Size);
  1514.  
  1515.     Relocate(&Get_Assignment_Lvalue(new));
  1516.     Relocate(&Get_Assignment_Rvalue(new));
  1517.  
  1518.     return new;
  1519. }
  1520.  
  1521.  
  1522. /* Definition  */
  1523.  
  1524. Op_Vector Definition_Ops = {
  1525.     Definition_Eval, Self_Compile,
  1526.         Definition_Print, Definition_Print, Definition_Print,
  1527.         Definition_GC};
  1528.  
  1529. Scheme_Type Definition_Type = &Definition_Ops;
  1530.  
  1531. Public void Make_Definition()
  1532. {
  1533.     Value_Register = Allocate(Definition_Size);
  1534.     Get_Definition_Lvalue(Value_Register) = Top(2);
  1535.     Get_Definition_Rvalue(Value_Register) = Top(1);
  1536.  
  1537.     Set_Result_Type(Definition_Type);
  1538.     Pop(2);
  1539. }
  1540.  
  1541. Public    Integer    Definition_Print( o , m )
  1542.  
  1543.     Object    o;
  1544.     Integer    m;
  1545. {
  1546.     Output( "(define " ); m += 8;
  1547.  
  1548.     m = Write_Object( Get_Definition_Lvalue( o ) , m );
  1549.  
  1550.     Output( " " ); m += 1;
  1551.  
  1552.     m = Write_Object( Get_Definition_Rvalue( o ) , m );
  1553.  
  1554.     Output( ")" ); m += 1;
  1555.     return( m );
  1556. }
  1557.  
  1558. Public Object Definition_GC(old)
  1559.  
  1560.     Object old;
  1561. {
  1562.     Object new = Move_Object(old, Definition_Size);
  1563.  
  1564.     Relocate(&Get_Definition_Lvalue(new));
  1565.     Relocate(&Get_Definition_Rvalue(new));
  1566.  
  1567.     return new;
  1568. }
  1569.  
  1570. /* Macro Definition Forms */
  1571.  
  1572. Op_Vector Macro_Ops = {
  1573.     Self_Eval, Self_Compile, Macro_Print, Macro_Print, Macro_Show,
  1574.         Macro_GC};
  1575.  
  1576. Scheme_Type Macro_Type = &Macro_Ops;
  1577.  
  1578. Public void Make_Macro()
  1579. {
  1580.     Value_Register = Allocate(Macro_Size);
  1581.     Get_Macro_Keyword(Value_Register) = Top(2);
  1582.     Get_Macro_Transformer(Value_Register) = Top(1);
  1583.  
  1584.     Set_Result_Type(Macro_Type);
  1585.     Pop(2);
  1586. }
  1587.  
  1588. Public    Integer    Macro_Print( o , m )
  1589.  
  1590.     Object    o;
  1591.     Integer    m;
  1592. {
  1593.     Integer    in_m = m;
  1594.  
  1595.     Output( "(macro " ); m += 7;
  1596.  
  1597.     m = Write_Object( Get_Macro_Keyword( o ) , m );
  1598.  
  1599.     if ( m >= 20 )
  1600.     { 
  1601.         m = New_Left_Margin( in_m + INDENT );
  1602.     }
  1603.     else
  1604.     {
  1605.         Output( " " ); m += 1;
  1606.     }
  1607.  
  1608.     m = Write_Object( Get_Macro_Transformer( o ) , m );
  1609.  
  1610.  
  1611.     Output( ")" ); m += 1;
  1612.     return( m );
  1613. }
  1614.  
  1615. Public    Integer    Macro_Show( o , m )
  1616.  
  1617.     Object    o;
  1618.     Integer    m;
  1619. {
  1620.     Output( "(macro " ); m += 7;
  1621.  
  1622.     m = Write_Object( Get_Macro_Keyword( o ) , m );
  1623.  
  1624.     Output( " ...)" ); m += 5;
  1625.  
  1626.     return( m );
  1627. }
  1628.  
  1629.  
  1630. Public Object Macro_GC(old)
  1631.  
  1632.     Object old;
  1633. {
  1634.     Object new = Move_Object(old, Macro_Size);
  1635.  
  1636.     Relocate(&Get_Macro_Keyword(new));
  1637.     Relocate(&Get_Macro_Transformer(new));
  1638.     return new;
  1639. }
  1640.  
  1641. /* Macro Call Forms. */
  1642.  
  1643. Op_Vector Macro_Call_Ops = {
  1644.     Macro_Call_Eval, Self_Compile,
  1645.         Macro_Call_Print, Macro_Call_Print, Macro_Call_Print,
  1646.         Macro_Call_GC};
  1647.  
  1648. Scheme_Type Macro_Call_Type = &Macro_Call_Ops;
  1649.  
  1650. Public void Make_Macro_Call()
  1651. {
  1652.     Value_Register = Allocate(Macro_Call_Size);
  1653.     Get_Macro_Call_Original(Value_Register) = Top(2);
  1654.     Get_Macro_Call_Expansion(Value_Register) = Top(1);
  1655.  
  1656.     Set_Result_Type(Macro_Call_Type);
  1657.     Pop(2);
  1658. }
  1659.  
  1660. Public    Integer    Macro_Call_Print( o , m )
  1661.  
  1662.     Object    o;
  1663.     Integer m;
  1664. {
  1665.     Integer    in_m = m;
  1666.  
  1667.     m = Write_Object( Get_Macro_Call_Original( o ) , m );
  1668.  
  1669.     m = New_Left_Margin( in_m );
  1670.     return( m );
  1671. }
  1672.  
  1673. Public Object Macro_Call_GC(old)
  1674.  
  1675.     Object old;
  1676. {
  1677.     Object new = Move_Object(old, Macro_Call_Size);
  1678.  
  1679.     Relocate(&Get_Macro_Call_Original(new));
  1680.     Relocate(&Get_Macro_Call_Expansion(new));
  1681.  
  1682.     return new;
  1683. }
  1684.  
  1685.  
  1686. /* Sequence. */
  1687.  
  1688. Op_Vector Sequence_Ops = {
  1689.     Sequence_Eval, Self_Compile, Sequence_Print,
  1690.         Sequence_Print, Sequence_Print, Sequence_GC};
  1691.  
  1692. Scheme_Type Sequence_Type = &Sequence_Ops;
  1693.  
  1694. Public void Make_Sequence(from_begin)
  1695.  
  1696.     Boolean from_begin;
  1697.  
  1698. {
  1699.     Value_Register = Allocate(Sequence_Size);
  1700.     Get_Sequence_Clauses(Value_Register) = Top(1);
  1701.     Get_Sequence_From_Begin(Value_Register) = from_begin;
  1702.  
  1703.     Set_Result_Type(Sequence_Type);
  1704.     Pop(1);
  1705. }
  1706.  
  1707. Public    Integer    Sequence_Print( o, m )
  1708.  
  1709.     Object    o;
  1710.     Integer m;
  1711. {
  1712.     Integer    in_m = m;
  1713.  
  1714.     if ( Get_Sequence_From_Begin( o ) )
  1715.     {
  1716.         Output("(begin ");  m += 6;
  1717.     } 
  1718.  
  1719.     o = Get_Sequence_Clauses( o );
  1720.     while ( o != Nil )
  1721.     {
  1722.         m = New_Left_Margin( in_m + INDENT );
  1723.         m = Write_Object( Get_Pair_Car( o ) , m );
  1724.         o = Get_Pair_Cdr( o );
  1725.     }
  1726.     Output( " )" ); m += 2;
  1727.     return( m );
  1728. }
  1729.  
  1730. Public Object Sequence_GC( old )
  1731.  
  1732.     Object old;
  1733. {
  1734.     Object new = Move_Object(old, Sequence_Size);
  1735.  
  1736.     Relocate(&Get_Sequence_Clauses(new));
  1737.  
  1738.     return new;
  1739. }
  1740.  
  1741. /* Delay. */
  1742.  
  1743. Op_Vector Delay_Ops = {
  1744.     Delay_Eval, Self_Compile, Delay_Print,
  1745.         Delay_Print, Delay_Print,  Delay_GC};
  1746.  
  1747. Scheme_Type Delay_Type = &Delay_Ops;
  1748.  
  1749. Public void Make_Delay()
  1750. {
  1751.     Value_Register = Allocate(Delay_Size);
  1752.     Get_Delay_Expression(Value_Register) = Top(1);
  1753.  
  1754.     Set_Result_Type(Delay_Type);
  1755.     Pop(1);
  1756. }
  1757.  
  1758. Public    Integer    Delay_Print( o, m )
  1759.  
  1760.     Object    o;
  1761.     Integer    m;
  1762. {
  1763.     Integer in_m = m;
  1764.  
  1765.     Output("(delay ");
  1766.     m = New_Left_Margin( in_m + INDENT );
  1767.  
  1768.     m = Write_Object( Get_Delay_Expression( o ) , m );
  1769.  
  1770.     Output(")"); m += 1;
  1771.  
  1772.     return( m );
  1773. }
  1774.  
  1775. Public Object Delay_GC(old)
  1776.  
  1777.     Object old;
  1778. {
  1779.     Object new = Move_Object(old, Delay_Size);
  1780.  
  1781.     Relocate(&Get_Delay_Expression(new));
  1782.  
  1783.     return new;
  1784. }
  1785.  
  1786. /* Promise. */
  1787.  
  1788. Op_Vector Promise_Ops = {
  1789.     Self_Eval, Self_Compile, Promise_Print,
  1790.         Promise_Print, Promise_Show,  Promise_GC};
  1791.  
  1792. Scheme_Type Promise_Type = &Promise_Ops;
  1793.  
  1794. Public void Make_Promise()
  1795. {
  1796.     Value_Register = Allocate(Promise_Size);
  1797.     Get_Promise_Expression(Value_Register) = Top(2);
  1798.     Get_Promise_Environment(Value_Register) = Top(1);
  1799.     Get_Promise_Forced(Value_Register) = FALSE;
  1800.     
  1801.     Set_Result_Type(Promise_Type);
  1802.     Pop(2);
  1803. }
  1804.  
  1805. Public    Integer    Promise_Print( o, m )
  1806.  
  1807.     Object    o;
  1808.     Integer    m;
  1809. {
  1810.     Integer    in_m = m;
  1811.  
  1812.     Output( "(PROMISE " ); 
  1813.     m = New_Left_Margin( in_m + INDENT );
  1814.  
  1815.     m = Write_Object( Get_Promise_Expression( o ) , m );
  1816.     Output( ")" ); m +=1;
  1817.     return( m );
  1818. }
  1819.  
  1820. Public    Integer    Promise_Show( o, m )
  1821.  
  1822.     Object    o;
  1823.     Integer    m;
  1824. {
  1825.     Output( "<PROMISE>" ); 
  1826.     return( m + 9 );
  1827. }
  1828.  
  1829. Public Object Promise_GC(old)
  1830.  
  1831.     Object old;
  1832. {
  1833.     Object new = Move_Object(old, Promise_Size);
  1834.  
  1835.     Relocate(&Get_Promise_Expression(new));
  1836.     Relocate(&Get_Promise_Environment(new));
  1837.  
  1838.     return new;
  1839. }
  1840.  
  1841.  
  1842. /* Error forms. */
  1843.  
  1844. Op_Vector Error_Ops = {
  1845.     Self_Eval, Self_Compile, Error_Print,
  1846.         Error_Print, Error_Print, Error_GC};
  1847.  
  1848. Scheme_Type Error_Type = &Error_Ops;
  1849.  
  1850. Public void Make_Error(message)
  1851.  
  1852.     String message;
  1853. {
  1854.     Value_Register = Allocate(Error_Size);
  1855.     Get_Error_Message(Value_Register) = Copy_String(message);
  1856.  
  1857.     Set_Result_Type(Error_Type);
  1858. }
  1859.  
  1860. Public    Integer    Error_Print( o, m )
  1861.  
  1862.     Object    o;
  1863.     Integer    m;
  1864. {
  1865.     Output( "(Error " ); m += 7;
  1866.     Output( Get_Error_Message( o ) ); m += strlen( Get_Error_Message( o ) );
  1867.     Output( ")" ); m += 1;
  1868.     return( m );
  1869. }
  1870.  
  1871. Public Object Error_GC(old)
  1872.  
  1873.     Object old;
  1874. {
  1875.     Object new = Move_Object(old, Error_Size);
  1876.  
  1877.     return new;
  1878. }
  1879.  
  1880.  
  1881. /* Environment Frame. */
  1882.  
  1883. Op_Vector Environment_Frame_Ops = {
  1884.     Environment_Frame_Eval, Self_Compile,
  1885.         Environment_Frame_Print,
  1886.         Environment_Frame_Print,
  1887.     Environment_Frame_Show,
  1888.         Environment_Frame_GC};
  1889.  
  1890. Scheme_Type Environment_Frame_Type = &Environment_Frame_Ops;
  1891.  
  1892. Public Object The_Global_Environment;
  1893.  
  1894. Private void Init_Environment_Frame()
  1895. {
  1896.     Make_Environment_Frame(0, FALSE); 
  1897.     The_Global_Environment = Value_Register;
  1898. }
  1899.  
  1900. Public void Make_Environment_Frame(size, has_rest)
  1901.     Integer size;
  1902.     Boolean has_rest;
  1903. {
  1904.     Integer newsize = ( size ? size : 1);
  1905.  
  1906.     Value_Register = Allocate(Environment_Frame_Size(newsize));
  1907.     Get_Environment_Frame_Previous(Value_Register) = Nil;
  1908.     Get_Environment_Frame_Size(Value_Register) = size;
  1909.     Get_Environment_Frame_Has_Rest(Value_Register) = has_rest;
  1910.  
  1911.     if (size == 0)
  1912.     {
  1913.         Get_Environment_Frame_Binding_Symbol(Value_Register,0) = Nil; 
  1914.         Get_Environment_Frame_Binding_Value(Value_Register,0) = Nil; 
  1915.         Get_Environment_Frame_Binding_How(Value_Register,0) = Nil; 
  1916.     }
  1917.     Set_Result_Type(Environment_Frame_Type);
  1918. }
  1919.  
  1920. Public void Make_Symbol_Frame()
  1921. {
  1922.     Object formals, frame;
  1923.     Object rest = Last_Cdr(Top(1));
  1924.     Integer numargs = Length(Top(1));
  1925.     Integer this_arg;
  1926.     Integer frame_size;
  1927.  
  1928.     frame_size  = numargs + ((rest == Nil) ? 0 : 1);
  1929.  
  1930.     Make_Environment_Frame(frame_size, rest != Nil);
  1931.     frame = Value_Register;
  1932.     formals = Top(1);
  1933.  
  1934.     for (this_arg = 0; this_arg < numargs; this_arg++)
  1935.     {
  1936.         Get_Environment_Frame_Binding_Symbol(frame,this_arg) = 
  1937.             First(formals);
  1938.         Get_Environment_Frame_Binding_Value(frame,this_arg) = 
  1939.             The_Undefined_Symbol;
  1940.         Get_Environment_Frame_Binding_How(frame,this_arg) = 
  1941.             An_Argument;
  1942.         formals = Rest(formals);
  1943.     }
  1944.     if (formals != Nil)
  1945.     {
  1946.         Get_Environment_Frame_Binding_Symbol(frame,numargs) = formals;
  1947.         Get_Environment_Frame_Binding_Value(frame,numargs) = 
  1948.             The_Undefined_Symbol;
  1949.         Get_Environment_Frame_Binding_How(frame,numargs) = 
  1950.             An_Argument;
  1951.     }
  1952.     Get_Environment_Frame_Has_Rest(frame) = (rest != Nil);
  1953.     Pop(1);
  1954. }
  1955.  
  1956. Public    Integer    Environment_Frame_Print( o, m )
  1957.  
  1958.     Object    o;
  1959.     Integer    m;
  1960. {
  1961.     Integer this_arg;
  1962.  
  1963.     Output("("); m += 1;
  1964.  
  1965.     for (this_arg = 0; this_arg < Get_Environment_Frame_Size(o)-1; 
  1966.          this_arg++)
  1967.     {
  1968.         m = Write_Object( 
  1969.             Get_Environment_Frame_Binding_Symbol(o,this_arg) , m );
  1970.         Output( " " ); m += 1;
  1971.     }
  1972.  
  1973.     if (Get_Environment_Frame_Has_Rest(o))
  1974.     {
  1975.         Output( ". " ); m += 2;
  1976.     }
  1977.  
  1978.     if (Get_Environment_Frame_Size(o) > 0)
  1979.     {
  1980.         m = Write_Object(
  1981.             Get_Environment_Frame_Binding_Symbol(o,
  1982.                     Get_Environment_Frame_Size(o)-1) , m );
  1983.     }
  1984.  
  1985.     Output( ")" );  m += 1;
  1986.     return( m );
  1987. }
  1988.  
  1989. Public    Integer    Environment_Frame_Show( o, m )
  1990.  
  1991.     Object    o;
  1992.     Integer    m;
  1993. {
  1994.     Integer    in_m = m;
  1995.     Integer binding;
  1996.  
  1997.     for (binding = 0; binding <= Get_Environment_Frame_Size(o)-1; 
  1998.          binding++)
  1999.     {
  2000.         m = Write_Object( 
  2001.             Get_Environment_Frame_Binding_Symbol(o,binding) , m );
  2002.         Output( "\t= " ); m += 3;
  2003.         
  2004.         m = Write_Object(
  2005.             Get_Environment_Frame_Binding_Value(o,binding) , m );
  2006.         m = New_Left_Margin( in_m );
  2007.     }
  2008.     return( m );
  2009. }
  2010.  
  2011.  
  2012. Public Object Environment_Frame_GC(old)
  2013.  
  2014.     Object old;
  2015. {
  2016.     Object new = Move_Object(old, Environment_Frame_Size(
  2017.         Get_Environment_Frame_Size(old)));
  2018.     Integer binding;
  2019.  
  2020.     Relocate(&Get_Environment_Frame_Previous(new));
  2021.     for (binding = 0; binding < Get_Environment_Frame_Size(new); binding++)
  2022.     {
  2023.         Relocate(&Get_Environment_Frame_Binding_Symbol( new, binding ));
  2024.         Relocate(&Get_Environment_Frame_Binding_Value( new, binding ));
  2025.         Relocate(&Get_Environment_Frame_Binding_How( new , binding ));
  2026.     }
  2027.  
  2028.     return new;
  2029. }
  2030.  
  2031. /* State Frame. */
  2032.  
  2033. Op_Vector State_Frame_Ops = {
  2034.     State_Frame_Eval, Self_Compile,
  2035.     State_Frame_Print, State_Frame_Print, State_Frame_Print,
  2036.     State_Frame_GC};
  2037.  
  2038. Scheme_Type State_Frame_Type = &State_Frame_Ops;
  2039.  
  2040. Public void Make_State_Frame()
  2041. {
  2042.     Value_Register = Allocate(State_Frame_Size);
  2043.  
  2044.     Set_Result_Type(State_Frame_Type);
  2045. }
  2046.  
  2047. Public    Integer    State_Frame_Print( o, m )
  2048.  
  2049.     Object    o;
  2050.     Integer    m;
  2051. {
  2052.     Output( "<state frame>" );
  2053.     return( m + 13 );
  2054. }
  2055.  
  2056. Public Object State_Frame_GC(old)
  2057.  
  2058.     Object old;
  2059. {
  2060.     Object new = Move_Object(old, State_Frame_Size);
  2061.  
  2062.     Relocate(&Get_State_Frame_Expression(new));
  2063.     Relocate(&Get_State_Frame_Environment(new));
  2064.     Relocate(&Get_State_Frame_Function(new));
  2065.     Relocate(&Get_State_Frame_Arguments(new));
  2066.     Relocate(&Get_State_Frame_State(new));
  2067.  
  2068.     return new;
  2069. }
  2070.  
  2071. /* Eclectics. */
  2072.  
  2073. Op_Vector Eclectic_Ops = {
  2074.     Self_Eval, Self_Compile,
  2075.         Eclectic_Print, Eclectic_Print, Eclectic_Print,
  2076.         Eclectic_GC};
  2077. Scheme_Type Eclectic_Type = &Eclectic_Ops;
  2078.  
  2079. Public Object The_Rparen_Object, The_Dot_Object;
  2080.  
  2081. Private void Init_Eclectic()
  2082. {
  2083.     The_Rparen_Object = Allocate(Eclectic_Size);
  2084.     The_Dot_Object = Allocate(Eclectic_Size);
  2085.  
  2086.     Get_Type(The_Rparen_Object) = Eclectic_Type;
  2087.     Get_Type_Name(The_Rparen_Object) = "Eclectic_Type/)";
  2088.     Get_Type(The_Dot_Object) = Eclectic_Type;
  2089.     Get_Type_Name(The_Dot_Object) = "Eclectic_Type/.";
  2090. }
  2091.  
  2092. Public    Integer    Eclectic_Print( o , m )
  2093.  
  2094.     Object    o;
  2095.     Integer    m;
  2096. {
  2097.     if (o == The_Rparen_Object)
  2098.     {
  2099.         Output( "<An extra `)'.>" );
  2100.         return( m + 15 );
  2101.     }
  2102.     else if (o == The_Dot_Object)
  2103.     {
  2104.         Output(" <An extra `.'.>" );
  2105.         return( m + 15 );
  2106.     }
  2107.     else
  2108.     {
  2109.         /* Although we don't do typechecking in any of the other
  2110.                 output routines, we may as well do it here, since it's not
  2111.                 costing us anything. */
  2112.         Panic("Eclectic_Print called on a non-junk");
  2113.         return( m );
  2114.     }
  2115. }     
  2116.  
  2117. Public Object Eclectic_GC(old)
  2118.  
  2119.     Object old;
  2120. {
  2121.     Object new = Move_Object(old, Eclectic_Size);
  2122.  
  2123.     return new;
  2124. }
  2125.  
  2126.  
  2127. /* Nothing should have this type. */
  2128. Public Scheme_Type The_Undefined_Type = (Scheme_Type)-1;
  2129.  
  2130. /* This type matches anything. */
  2131. Public Scheme_Type Any_Type = (Scheme_Type) -2;
  2132.  
  2133.  
  2134.  
  2135. /* Called once at boot time. */
  2136.  
  2137. Public void Initialize_Object()
  2138. {
  2139.     Init_Boolean();
  2140.     Init_Eclectic();
  2141.     Init_Empty_List();
  2142.     Init_Symbol();
  2143.     Init_Port();
  2144.     Init_Eof();
  2145.     Init_Environment_Frame();
  2146. }
  2147.