home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / oct93 / develop / umbscheme.lha / UMBScheme / src / eval.c < prev    next >
C/C++ Source or Header  |  1992-08-04  |  11KB  |  534 lines
  1. /* eval.c -- UMB Scheme, explicit control evaluator.
  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 <setjmp.h>
  37. #include "portable.h"
  38. #include "eval.h"
  39. #include "object.h"
  40. #include "architecture.h"
  41. #include "steering.h"
  42. #include "debug.h"
  43. #include "io.h"
  44.  
  45.  
  46. #define    Goto(x)    PC_Register = (x)
  47.  
  48. Public    jmp_buf    Eval_Loop;
  49.  
  50. Private void Call_Primitive();
  51. Private void Restore_Continuation_State();
  52.  
  53.  
  54. Public void Self_Eval( Expression )
  55.  
  56. Object    Expression ;    /* Evalauates to itself */
  57. {
  58.     Value_Register = Expression ;
  59.     Restore();
  60. }
  61.  
  62.  
  63.  
  64. Public void Eval( Expression , Environment )
  65.  
  66.     Object    Expression ;    /* To be evaluated */
  67.     Object    Environment;
  68. {
  69.     Boolean    saved_evaluating = Evaluating;
  70.  
  71.     Expression_Register = Expression ;
  72.     Value_Register = Nil ;
  73.     Function_Register = Nil ;
  74.     Environment_Register = Environment;
  75.     PC_Register = RETURN ;
  76.  
  77.     Save() ;
  78.  
  79.     PC_Register = EVAL_EXPRESSION ;
  80.  
  81.     if ( Debugger_Activated )
  82.     {
  83.         Evaluating = TRUE;
  84.         setjmp( Eval_Loop ); 
  85.  
  86.         if ( Evaluation_Broken )
  87.         {
  88.             Evaluation_Broken = FALSE;
  89.             Output( "\nBreak:\t" );
  90.             (void) Show_Object( Expression_Register , 9 );
  91.  
  92.             Steer_Debugging();
  93.             if ( Go_Processed )
  94.             {
  95.                 Restore();
  96.                 Go_Processed = FALSE;
  97.             }
  98.             else
  99.             {
  100.                 Reset();
  101.             }
  102.         }
  103.     }
  104.  
  105.     while ( PC_Register != RETURN )
  106.     {
  107.         switch( PC_Register )
  108.         {
  109.         case EVAL_EXPRESSION:
  110.             if ( Debugger_Activated && Stepping )
  111.             {
  112.                 if ( (--Stepper) == 0 )
  113.                 {
  114.                     Debugger_Activated = FALSE;
  115.                     Output( "\nStep:\t" );
  116.                     (void) Show_Object( Expression_Register,
  117.                                 9 );
  118.                     Steer_Debugging();
  119.                     Debugger_Activated = TRUE;
  120.                     Stepper = Stepping;
  121.                     if ( Go_Processed )
  122.                     {
  123.                         Restore();
  124.                         Go_Processed = FALSE;
  125.                         break;
  126.                     }
  127.                 }
  128.             }
  129.             Eval_Object( Expression_Register ) ;
  130.             break;
  131.  
  132.         case EVAL_APPLY:
  133.             Function_Register = Value_Register;
  134.             Arguments_Register = Get_Apply_Arguments( 
  135.             Expression_Register );
  136.  
  137.         case EVAL_ARGUMENTS:
  138.             LABEL_ARGUMENTS:
  139.             if ( Arguments_Register != Nil )
  140.             {
  141.                 if ( !Is_Pair( Arguments_Register ) )
  142.                 {
  143.                     Display_Error( 
  144.                     "Arguments must be a list:",
  145.                          Arguments_Register );
  146.                 }
  147.  
  148.                 PC_Register = STACK_ARGUMENT;
  149.                 Save();
  150.  
  151.                 Expression_Register = First( 
  152.                         Arguments_Register );
  153.                 Goto( EVAL_EXPRESSION );
  154.                 break;
  155.             }
  156.  
  157.             /* Otherwise, fall through */
  158.  
  159.         case PERFORM_APPLICATION:
  160.  
  161.             if ( Evaluating )
  162.             {
  163.                 if (Tracing && (Tracing_All || 
  164.                 Traced( Function_Register ) ) )
  165.                 {
  166.                 Integer left;
  167.                 Integer arg = Get_Apply_Numargs( 
  168.                         Expression_Register );
  169.                 Save();
  170.                 
  171.                 left = New_Left_Margin( Trace_Margin );
  172.                 Trace_Right();
  173.                 Output( "Trace: (" ); left += 8;
  174.                 Output( Name_For( Function_Register ) );
  175.                 left += strlen( Name_For( Function_Register ) );
  176.                 while (arg)
  177.                 {
  178.                     Output( " " ); left++;
  179.                     left = Show_Object( Top(arg) , left );
  180.                     arg--;
  181.                 }
  182.                 Output( ")" ); left++;
  183.                 
  184.                 Restore();
  185.  
  186.                 Steer_Debugging();
  187.                 if ( Go_Processed )
  188.                 {
  189.                     Restore();
  190.                     Go_Processed = FALSE;
  191.                     break;
  192.                 }
  193.                 }
  194.  
  195.                 PC_Register = APPLICATION_COMPLETE;
  196.                 Save();
  197.             }
  198.  
  199.             if ( Is_Primitive( Function_Register ) )
  200.             {
  201.                 Call_Primitive( Function_Register );
  202.             }
  203.             else if ( Is_Procedure( Function_Register ) )
  204.             { 
  205.                 Extend_Environment(Get_Apply_Numargs(
  206.                          Expression_Register));
  207.                 Expression_Register = Get_Procedure_Body(
  208.                         Function_Register);
  209.                 Goto( EVAL_EXPRESSION );
  210.             }
  211.             else if ( Is_Continuation( Function_Register ) )
  212.             {
  213.                 if ( Get_Apply_Numargs(Expression_Register)!= 1)
  214.                 {
  215.                     Display_Error( 
  216.  
  217.                     "Continuation requires one argument:",
  218.                     Expression_Register);
  219.                 }
  220.  
  221.                 Value_Register = Top(1);
  222.                 Restore_Continuation_State( Function_Register );
  223.             }
  224.             else
  225.             {
  226.                 Display_Error( "Bad function object:",
  227.                     Function_Register );
  228.             }
  229.             break;
  230.  
  231.         case APPLICATION_COMPLETE:
  232.  
  233.             if (Tracing && (Tracing_All || 
  234.                 Traced( Function_Register ) ) )
  235.             {
  236.                 Integer left;
  237.                 Trace_Left();
  238.                 left = New_Left_Margin( Trace_Margin ); 
  239.                 Output( "Trace: Value = " ); left += 15;
  240.                 left = Show_Object( Value_Register , left );
  241.  
  242.                 Steer_Debugging();
  243.                 Go_Processed = FALSE;
  244.             }
  245.             Restore();
  246.             break;
  247.  
  248.         case STACK_ARGUMENT:
  249.             Push( Value_Register );
  250.             Arguments_Register = Rest( Arguments_Register );
  251.             goto LABEL_ARGUMENTS;
  252.  
  253.         case EVAL_DEFINITION:
  254.             Define( Get_Definition_Lvalue( Expression_Register ),
  255.                 Value_Register,
  256.                 Environment_Register );
  257.             Restore();
  258.             break;
  259.  
  260.         case EVAL_CONDITIONAL:
  261.             Expression_Register =
  262.                 Is_False( Value_Register )
  263.                 ? Get_Conditional_Alternate( Expression_Register )
  264.                 : Get_Conditional_Consequent( Expression_Register );
  265.             Goto( EVAL_EXPRESSION );
  266.             break;
  267.  
  268.  
  269.         case EVAL_SEQUENCE:
  270.             Expression_Register = First( Arguments_Register ) ;
  271.             Arguments_Register = Rest( Arguments_Register );
  272.             if (  Is_Pair( Arguments_Register ) )
  273.             {
  274.                 /* More clauses after this.  Must save state. */
  275.                 PC_Register = EVAL_SEQUENCE ;
  276.                 Save();
  277.             }
  278.             Goto( EVAL_EXPRESSION );
  279.             break;
  280.  
  281.         case EVAL_ASSIGNMENT:
  282.             Assign( Get_Assignment_Lvalue( Expression_Register ),
  283.                 Value_Register,
  284.                 Environment_Register );
  285.             Restore();
  286.             break;
  287.             
  288.             case OVERWRITE_PROMISE:
  289.             Get_Promise_Expression( Expression_Register ) =
  290.                 Value_Register;
  291.             Get_Promise_Forced( Expression_Register ) = TRUE;
  292.             Restore();
  293.             break;
  294.  
  295.  
  296.             
  297.         default:
  298.             Panic( "Bad Evaluation Label in Evaluate()" );
  299.         }
  300.     }
  301.     if ( Debugger_Activated )
  302.     {
  303.         Evaluating = saved_evaluating;
  304.     }
  305. }
  306.  
  307.  
  308. Public void Apply_Eval()
  309. {
  310.     PC_Register = EVAL_APPLY ;
  311.     Save();
  312.  
  313.     /* Firstly, evaluate operator */
  314.  
  315.     Expression_Register = Get_Apply_Operator( Expression_Register );
  316.     Goto( EVAL_EXPRESSION );
  317. }
  318.  
  319.  
  320. Public void Lambda_Eval()
  321. {
  322.     /* Lambdas evaluate to procedures, closed in the current env */
  323.  
  324.     Push( Expression_Register );
  325.     Make_Procedure();
  326.  
  327.     Restore();
  328. }
  329.  
  330.  
  331. Public void Conditional_Eval()
  332. {
  333.     PC_Register = EVAL_CONDITIONAL;
  334.     Save();
  335.  
  336.     /* Firstly, evaluate test predicate */
  337.  
  338.     Expression_Register = Get_Conditional_Test( Expression_Register );
  339.     Goto( EVAL_EXPRESSION );
  340. }
  341.  
  342.  
  343.  
  344. Public void Assignment_Eval()
  345. {
  346.     PC_Register = EVAL_ASSIGNMENT;
  347.     Save();
  348.  
  349.     /* Firstly, evaluate value to be assigned (rhs) */
  350.  
  351.     Expression_Register = Get_Assignment_Rvalue( Expression_Register );
  352.     Goto( EVAL_EXPRESSION );
  353. }
  354.  
  355.  
  356.  
  357. Public void Definition_Eval()
  358. {
  359.     PC_Register = EVAL_DEFINITION;
  360.     Save();
  361.  
  362.     /* Firstly, evaluate defining expression */
  363.  
  364.     Expression_Register = Get_Definition_Rvalue( Expression_Register );
  365.     Goto( EVAL_EXPRESSION );
  366. }
  367.  
  368.  
  369.  
  370. Public void Macro_Call_Eval()
  371. {
  372.     /* Evaluate the expanded form, of course */
  373.  
  374.     Expression_Register = Get_Macro_Call_Expansion( Expression_Register );
  375.     Goto( EVAL_EXPRESSION );
  376. }
  377.  
  378.  
  379.  
  380. Public void Sequence_Eval()
  381. {
  382.     Arguments_Register = Get_Sequence_Clauses( Expression_Register );
  383.  
  384.     /* Special case the empty sequence */
  385.  
  386.     if ( Arguments_Register == Nil )
  387.     {
  388.         Value_Register = Nil;
  389.         Restore();
  390.     }
  391.     else
  392.     {
  393.         if (!Is_Pair(Arguments_Register))
  394.         {
  395.             Display_Error( "Body sequence must be a list:",
  396.                 Arguments_Register );
  397.         }
  398.  
  399.         Goto( EVAL_SEQUENCE );
  400.     }
  401. }
  402.  
  403.  
  404.  
  405. Public void Delay_Eval()
  406. {
  407.     Push( Get_Delay_Expression( Expression_Register ) );
  408.     Push( Environment_Register );
  409.     Make_Promise();
  410.     Restore();
  411. }
  412.  
  413.  
  414.  
  415. Public void Variable_Eval()
  416. {
  417.     if ( Is_Local_Variable( Expression_Register ) )
  418.     {
  419.         Object    env =    Environment_Register;
  420.         Integer frame;
  421.  
  422.         for ( frame = 0; 
  423.               frame < Get_Variable_Frame_Number( Expression_Register );
  424.               frame++ ) env = Get_Environment_Frame_Previous(env);
  425.         Value_Register = 
  426.             Get_Environment_Frame_Binding_Value( env,
  427.             Get_Variable_Displacement( Expression_Register ));
  428.     }
  429.     else
  430.     {
  431.         Value_Register =
  432.             Get_Global_Binding( Get_Variable_Symbol(
  433.                         Expression_Register ) );
  434.     }
  435.  
  436.     if ( Value_Register == The_Undefined_Symbol )
  437.     {
  438.         Error1( "`%s' is undefined" , 
  439.             Get_Symbol_Name(Get_Variable_Symbol(Expression_Register)));
  440.     }
  441.     Restore();  /* !!!!!! */
  442. }
  443.  
  444.  
  445.  
  446. Public void Environment_Frame_Eval()
  447. {
  448.     Panic( "Attempt to evaluate an environment frame" );
  449. }
  450.  
  451.  
  452.  
  453.  
  454.  
  455. Public void State_Frame_Eval()
  456. {
  457.     Panic( "Attempt to evaluate a state frame" );
  458. }
  459.  
  460.  
  461.  
  462. Private void Restore_Continuation_State( c )
  463.  
  464.     Object    c;
  465. {
  466.     Integer this_elem;
  467.  
  468.     State_Register = Get_Continuation_State( c ); /* State to be restored */
  469.     Restore();
  470.  
  471.     for (this_elem = 0; this_elem < Arg_Stack_Ptr; this_elem++)
  472.     {
  473.         Arg_Stack[this_elem] = Get_Continuation_Stack_Elem(c,this_elem);    
  474.     }
  475. }
  476.  
  477.  
  478.  
  479. Private void Call_Primitive( f )
  480.  
  481.     Object    f ;    /* The Primitive (function) Object */
  482. {
  483.     Integer actual_arg_count = Get_Apply_Numargs( Expression_Register );
  484.     Integer formal_arg_count = Get_Primitive_Numargs( f );
  485.     Integer counter = 0; /* for type checking */
  486.  
  487.     /* Check number of arguments */
  488.  
  489.     if ( actual_arg_count!=formal_arg_count && formal_arg_count!=VARYING )
  490.     {
  491.         Display_Error( "Incorrect number of arguments to primitive: ",
  492.             Expression_Register );
  493.     }
  494.  
  495.  
  496.     /* Check types of the individual arguments (on stack) */
  497.  
  498.     if ( formal_arg_count == VARYING )
  499.     {
  500.         formal_arg_count = actual_arg_count;
  501.         while ( formal_arg_count )
  502.         {
  503.         if ( (Get_Type( Top( formal_arg_count ) ) !=
  504.             Get_Primitive_Argtypes(f,0)) &&
  505.             (Get_Primitive_Argtypes(f,0) != Any_Type) )
  506.         {
  507.             Display_Error( "Bad argument type to primitive in: ",
  508.                 Expression_Register );
  509.         }
  510.         formal_arg_count-- ;
  511.         }
  512.     }
  513.     else
  514.     {
  515.         while ( formal_arg_count )
  516.         {
  517.         if ( (Get_Type( Top( formal_arg_count ) ) !=
  518.             Get_Primitive_Argtypes(f,counter)) &&
  519.             (Get_Primitive_Argtypes(f,counter) != Any_Type) )
  520.         {
  521.             Display_Error( "Bad argument type to primitive in: ",
  522.                 Expression_Register );
  523.         }
  524.         counter++ ;
  525.         formal_arg_count-- ;
  526.         }
  527.     }
  528.  
  529.     (*Get_Primitive_Procedure(f))() ;    /* Invoke the C routine */
  530.  
  531.     Pop( actual_arg_count );
  532.     Restore();
  533. }
  534.