home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / scheva.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-26  |  37.6 KB  |  1,050 lines

  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHEVA.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       88/11/24
  9. **
  10. ** DESCRIPTION: This module contains the DScheme evaluator.
  11. ***********************************************************************
  12. ** CHANGES INFORMATION **
  13. *************************
  14. ** REVISION:    $Revision:   1.0  $
  15. ** CHANGER:     $Author:   JAN  $
  16. ** WORKFILE:    $Workfile:   scheva.c  $
  17. ** LOGFILE:     $Logfile:   C:/CPROG/SCHEME/VCS/SCHEVA.C_V  $
  18. ** LOGINFO:     $Log:   C:/CPROG/SCHEME/VCS/SCHEVA.C_V  $
  19. **              
  20. **                 Rev 1.0   12 Oct 1989 11:46:38   JAN
  21. **              Initial revision.
  22. **********************************************************************/
  23. #include "schinc.h"
  24. #include "schdef.h"
  25.  
  26. extern TCALL tracer;                                            /* trace hook */
  27. CELP  key;                                             /* Current key pointer */
  28. CELP  walker;                                                  /* List walker */
  29.  
  30. #define VARARG 0x01
  31.  
  32. STATIC CELP  PASCAL  DsReplace      __((CELP expr));
  33. STATIC int   PASCAL  DsSearchFrame  __((CELP p));
  34. STATIC int   PASCAL  DsSetFrame     __((CELP p, CELP name));
  35. STATIC void  PASCAL  DsVarArg       __((void));
  36. STATIC void  PASCAL  DsSetVar       __((CELP name));
  37. STATIC CELP  PASCAL  DsCallExternal __((int));
  38. STATIC CELP  PASCAL  DsApplyKernel  __((int));
  39. STATIC void  PASCAL  DsEvalItem     __((void));
  40. STATIC void  PASCAL  DsMakeDefine   __((void));
  41. STATIC void  PASCAL  DsMakeProc     __((CELP formals));
  42. STATIC void  PASCAL  DsMakeMacro    __((void));
  43. STATIC int   PASCAL  DsValues       __((int mode));
  44. STATIC void  PASCAL  DsLookup       __((void));
  45. STATIC CELP  PASCAL  DsFormals      __((CELP formals, int dotted));
  46.  
  47.  
  48.  /***************************************************************
  49.  ** COMPILEBODY Makes nested defines samewhat faster, but a nested
  50.  ** define can't access the parameters of its parent define.
  51.  ** Example:
  52.  ** (define (power a b)
  53.  **    (define (square) (* a a))
  54.  **    (* (square) b))
  55.  ** the lambda form square can't access the parameter a of its
  56.  ** parent. This is considered a bug and should be repaired.
  57.  ** This is not easy. The nested defines should have there own
  58.  ** extended env. in the at call time of the parent ext.env.
  59.  ****************************************************************/
  60. #ifdef COMPILEBODY
  61. STATIC CELP  PASCAL  DsBodyCheck    __((CELP body));
  62. #else
  63. #define DsBodyCheck(p) p
  64. #endif
  65.  
  66. /***************************************************************
  67. ** NAME:        DsEval
  68. ** SYNOPSIS:    CELP DsEval(arg);
  69. **              item    The item to evaluate
  70. ** DESCRIPTION: The expression is evaluated in the current
  71. **              environment. If it is an self-evaluating
  72. **              expression, the item is returned 'unevalled'.
  73. **              Otherwise is the item is passed to the real
  74. **              evaluator. (DsEvalComplex)
  75. ** RETURNS:     The result of the expression.
  76. ***************************************************************/
  77. CELP PASCAL DsEval(exp)
  78. CELP exp;
  79. {
  80.     PUSH(item=exp);                        /* save this topexpression from GC */
  81.     DsEvalItem();
  82.     POP;                                         /* Done with this expression */
  83.     return item;
  84. }
  85.  
  86.  
  87. /***************************************************************
  88. ** NAME:        DsEvalItem
  89. ** SYNOPSIS:    CELP DsEvalItem();
  90. ** DESCRIPTION: Eval_item is called by the eval routine, when
  91. **              a complex expression is found. Eval_complex
  92. **              checks for special forms, macro's, lambda's and
  93. **              tail-recursivity of the expression.
  94. ** RETURNS:     The result of the expression.
  95. ***************************************************************/
  96.  
  97. STATIC
  98. void PASCAL DsEvalItem()
  99. {
  100. #ifndef FIXEDGLO
  101.     register GLOBAL *EvalGlo=PGLOBAL;
  102. # undef GLOB
  103. # define GLOB(x) (EvalGlo->x)
  104. #endif
  105.  
  106.     if (ISNIL(item))
  107.     {
  108.         tracer(T_SELF);
  109.         return;
  110.     }
  111.     if (TAGpart(item)!=TYPE_PAIR)
  112.     {
  113.         if (_ISVAR(item))
  114.         {
  115.             DsLookup();
  116.             tracer(T_LOOKUP);
  117.             return;
  118.         }
  119.         tracer(T_SELF);
  120.         return;
  121.     }                                              /* else complex evaluation */
  122.  
  123.     STKADD(4);                                    /* reserve some stack space */
  124.     STKARG(4)=key;                                      /* fill a stack frame */
  125.     STKARG(3)=GLOB(curexp);
  126.     STKARG(2)=GLOB(curenv);                       /* Save current environment */
  127.     STKARG(1)=GLOB(curargs);
  128.  
  129.     tracer(T_START);
  130.     goto skipit;                                               /* quick start */
  131.  
  132. restart:
  133.     if (ISNIL(item)) goto exit;
  134.     if (TAGpart(item)!=TYPE_PAIR)                   /* only pairs are complex */
  135.     {
  136.         if (_ISVAR(item))
  137.         {
  138.             DsLookup();
  139.             tracer(T_LOOKUP);
  140.             goto exit;
  141.         }
  142.         tracer(T_SELF);
  143.         goto exit;
  144.     }
  145.     tracer(T_TAIL);
  146.  
  147. skipit:                                       /* serious business starts here */
  148.     GLOB(curexp)=item;                         /* remember current expression */
  149.     key=CARpart(item);
  150.     item=CDRpart(item);
  151.     switch(TAG(key))
  152.     {
  153.     case TYPE_KEY:                                        /* kernel function? */
  154.         if (ARGpart(key))
  155.             if ((SHORT)DsLength(item)<ARGpart(key))
  156.                 DSERROR(ERRARC,key);
  157.         switch (KEYpart(key))
  158.         {                               /* Q_true points to Cel with true val */
  159.         case IP_DEF:                           /* item= ( (sum x y) (+ x y) ) */
  160.             DsMakeDefine();
  161.             goto exit;
  162.  
  163.         case IP_QUOTE:
  164.             item=CARpart(item);                /* return argument unevaluated */
  165.             goto exit;
  166.  
  167.         case IP_LAMBDA:                         /* at least 2: ((x) (body)..) */
  168.             key=CARpart(item);
  169.             item=CDRpart(item);
  170.             DsMakeProc(key);       /* turn (lambda (x y) (+ x y)) into a proc */
  171.             goto exit;
  172.  
  173.         case IP_IF :                           /* ((test) (exp) <(else_exp)>) */
  174.             PUSH(CDRpart(item));           /* store second part of expression */
  175.             item=CARpart(item);                              /* get test part */
  176.             DsEvalItem();                                    /* evaluate item */
  177.             key=*POP;                                      /* pop second part */
  178.             if (ISFALS(item))                          /* evaluate test expr. */
  179.             {
  180.                 key=CDRpart(key);                       /* get third argument */
  181.                 if (ISNIL(key))                 /* else branch doesn't exist? */
  182.                     goto exit;                            /* no, end of eval. */
  183.             }
  184.             item=CARpart(key);                      /* get choosen expression */
  185.             goto restart;                    /* This enables Tail-resursivity */
  186.  
  187.         case IP_SET:                           /* 2: (A 1), rest is discarded */
  188.             key=CARpart(item);                          /* get first argument */
  189.             item=CADRpart(item);                       /* get second argument */
  190.             DsEvalItem();                                    /* evaluate item */
  191.             DsSetVar(key);
  192.             goto exit;
  193.  
  194.         case IP_BEGIN:                 /* Item has list of expression ie body */
  195.             item=DsBodyCheck(item);             /* Check if there are defines */
  196.         begin_loop:
  197.             key=item;
  198.             if (ISNIL(key)) goto exit;
  199.             while (1)
  200.             {
  201.                 item=CARpart(key);                  /* get current expression */
  202.                 key=CDRpart(key);                             /* next element */
  203.                 if (ISNIL(key))  /* current expression is last one so restart */
  204.                     goto restart;               /* function is tail resursive */
  205.                 DsEvalItem();        /* evaluate, discard result and continue */
  206.             }
  207.  
  208.         case IP_COND:
  209.             key=item;
  210.             while (ISTRUE(key))
  211.             {
  212.                 item=DsCaar(key);                           /* eval predicate */
  213.                 DsEvalItem();                 
  214.                 if (ISTRUE(item))                              /* test result */
  215.                 {
  216.                     item=CDARpart(key);               /* evaluate this clause */
  217.                     goto begin_loop;
  218.                 }
  219.                 key=CDRpart(key);
  220.             }
  221.             goto exit;
  222.  
  223.         case IP_CASE:                                    /* ( <key> <list>* ) */
  224.             key=CDRpart(item);                             /* list of clauses */
  225.             item=CARpart(item);                              /* eval key part */
  226.             DsEvalItem();                                /* evaluate key part */
  227.             while (ISTRUE(key))
  228.             {
  229.                 walker=DsCaar(key);                       /* get first clause */
  230.                 if (walker==Q_else                             /* else clause */
  231.                   || (ISTRUE(DsMemV(item,walker))))              /* found key */
  232.                 {
  233.                     item=CDARpart(key);            /* get expr part of clayse */
  234.                     goto begin_loop;                         /* evaluate this */
  235.                 }
  236.                 key=CDRpart(key);
  237.             }
  238.             goto exit;
  239.  
  240.         case IP_LET:
  241.         case IP_LETA:
  242.         case IP_LETREC:                                             /* LETREC */
  243.             PUSH(CDRpart(item));                          /* push body of let */
  244.             item=CARpart(item);                               /* get bindings */
  245.             GLOB(curenv)=DsCons(DsCons1(NIL), GLOB(curenv));     /* new frame */
  246.             if (KEYpart(key)==IP_LETREC)                     /* Recursive let */
  247.             {
  248.                 walker=item;
  249.                 item=Q_undef;                             /* for each binding */
  250.                 while (ISTRUE(walker))
  251.                 {
  252.                     DsDefVar(DsCaar(walker));              /* bind to *UNDEF* */
  253.                     walker=CDRpart(walker);
  254.                 }
  255.             }
  256.             else
  257.                 key=item;
  258.             while (ISTRUE(key))
  259.             {                                          /* key ((x 10) (y 20)) */
  260.                 item=DsCadar(key);                                  /* get 10 */
  261.                 DsEvalItem();                                      /* eval it */
  262.                 DsDefVar(CAARpart(key));              /* and bind result to x */
  263.                 key=CDRpart(key);                             /* next binding */
  264.             }
  265.             item=*POP;                                       /* get body part */
  266.             goto begin_loop;
  267.                         
  268.         case IP_MACRO:
  269.             DsMakeMacro();                /* eval (macro (when x y) (if x y)) */
  270.             goto exit;
  271.  
  272.         case IP_DO :                                               /* DO loop */
  273.         case IP_DELAY:                                               /* delay */
  274.             DSERROR(ERRNOT,key);
  275.             goto exit;
  276.  
  277.         case IP_APPLY:
  278.             goto restart;     /* Restart with the arguments as the expression */
  279.  
  280.         case IP_EVAL:
  281.             switch (DsValues(0))                        /* evaluate arguments */
  282.             {
  283.             case 2 : TYPCHECK(CDRpart(item),TYPE_PAIR);
  284.                      GLOB(curenv)=CDRpart(item);
  285.             case 1 : break;
  286.             default: DSERROR(ERRARC,key);
  287.             }
  288.             item=CARpart(item);                         /* get first argument */
  289.             goto restart;
  290.  
  291.         case IP_CONS:
  292.             DsValues(0);
  293.             goto exit;
  294.  
  295.         case IP_LIST:
  296.             DsValues(1);
  297.             goto exit;
  298.  
  299.         case IP_NULL:
  300.         case IP_NOT:
  301.             DsValues(0);
  302.             item=(ISNIL(item))?Q_true:NIL;
  303.             goto exit;
  304.  
  305.         case IP_AND:
  306.             if (ISNIL(item))
  307.             {
  308.                 item=Q_true;
  309.                 goto exit;
  310.             }
  311.             key=item;
  312.             do
  313.             {
  314.                 item=CARpart(key);                  /* get current expression */
  315.                 key=CDRpart(key);                             /* next element */
  316.                 if (ISNIL(key))  /* current expression is last one so restart */
  317.                     goto restart;               /* function is tail resursive */
  318.                 DsEvalItem();        /* evaluate, discard result and continue */
  319.             }
  320.             while (!ISFALS(item));
  321.             goto exit;
  322.  
  323.         case IP_OR:
  324.             key=item;
  325.             if (ISNIL(item)) goto exit;
  326.             do
  327.             {
  328.                 item=CARpart(key);                  /* get current expression */
  329.                 key=CDRpart(key);                             /* next element */
  330.                 if (ISNIL(key))  /* current expression is last one so restart */
  331.                     goto restart;               /* function is tail resursive */
  332.                 DsEvalItem();        /* evaluate, discard result and continue */
  333.             }
  334.             while (ISFALS(item));            /* quit on first true expression */
  335.             goto exit;
  336.  
  337.         case IP_EXIT    :
  338.             DSVERROR(ERRXIT);                                 /* quit DScheme */
  339.             goto exit;
  340.  
  341.         case IP_BREAK   :
  342.             DSVERROR(ERRBREAK);                             /* back to prompt */
  343.             goto exit;
  344.  
  345.         case IP_VERSION :
  346.             STRCEL(item,VERSION);
  347.             goto exit;
  348.  
  349.         case IP_COLLECT :
  350.             GLOB(GCflag)=3;                       /* also defrag string space */
  351.             item=DsGetCell(TYPE_INT);          /* Get cell to store answer in */
  352.             INTpart(item)=DsGarbageCollect(item); /* Collect, except for item */
  353.             goto exit;
  354.  
  355.         default:                                /* Handle it as a normal form */
  356.             item = DsApplyKernel(DsValues(0));    /* call the kernel function */
  357.         }
  358.         goto exit;                                      /* End of eval's task */
  359.  
  360.     case TYPE_MAC:
  361.         walker=CAARpart(key);                              /* list of formals */
  362.     if (ARGpart(walker))
  363.     {
  364.             if (KEYpart(walker) & VARARG)
  365.         {
  366.                 DsVarArg();                      /* rebuild list of arguments */
  367.                 if (DsLength(item)<ARGpart(walker))
  368.                     DSERROR(ERRARC,key);
  369.             }
  370.             else
  371.                 if ((SHORT)DsLength(item)!=ARGpart(walker))
  372.             DSERROR(ERRARC,key);    
  373.             walker=CDRpart(walker);                 /* actual list of formals */
  374.             item=DsReplace(CDARpart(key));  /*replace formals in body by args */
  375.         }
  376.     else
  377.     {
  378.             if (item) DSERROR(ERRARC,key);                 /* No args please! */
  379.         item=CDARpart(key);
  380.         }
  381.     tracer(T_MACRO);
  382.         goto begin_loop;                          /* eval it the official way */
  383.  
  384.     case TYPE_SPC:
  385.         if (KEYpart(key)==IP_EOF)
  386.             DSVERROR(ERREOF);                               /* end of input!! */
  387.         goto exit;
  388.  
  389.     default:                             /* Evaluate first part of expression */
  390.         {
  391.             register int ArgLen;
  392.                 
  393.             ArgLen=DsValues(0);                         /* evaluate arguments */
  394.             item=key;                        
  395.             DsEvalItem();                                /* evaluate key part */
  396.             key=item;
  397.             item=GLOB(curargs);
  398.             tracer(T_APPLY);
  399.             switch(TAG(key))               /* Apply key to arguments on stack */
  400.             {
  401.             case TYPE_KEY:                   /* proc part evaluated to a key? */
  402.                 if (ARGpart(key)!=ArgLen) DSERROR(ERRARC,key);
  403.                 item = DsApplyKernel(ArgLen);   /* Yep, its a kernel function */
  404.                 goto exit;                              /* End of eval's task */
  405.  
  406.             case TYPE_PRC:      /* evaluate body of procedure in extended env */
  407.                 walker=CDRpart(key);                     /* Get body and env. */
  408.                 key=CARpart(key);                             /* get PRC cell */
  409.                 if (KEYpart(key) & VARARG)
  410.             {
  411.                     DsVarArg();                  /* rebuild list of arguments */
  412.                     if (DsLength(item)<ARGpart(key))
  413.                         DSERROR(ERRARC,key);
  414.                 }
  415.                 else
  416.                     if (ArgLen!=ARGpart(key))
  417.             DSERROR(ERRARC,key);    
  418.                 GLOB(curenv)=DsCons(DsCons(CDRpart(key),item),CDRpart(walker));
  419.                 item=CARpart(walker);                            /* take body */
  420.                 goto begin_loop;                             /* do begin loop */
  421.  
  422.             case TYPE_EXT:
  423.                 item = DsCallExternal(ArgLen);
  424.                 goto exit;
  425.  
  426.             default:                               /* If it ain't a user proc */
  427.                 DSERROR(ERRPRC,key);                                /* Error! */
  428.                 goto exit;
  429.             }
  430.         }
  431.     }
  432. exit:
  433.     if (GLOB(GCflag)) DsGarbageCollect(item);                /* Clean mess up */
  434.     GLOB(curargs)=*POP;
  435.     GLOB(curenv)=*POP;                                 /* restore environment */
  436.     GLOB(curexp)=*POP;
  437.     key=*POP;
  438.     tracer(T_END);
  439. #ifndef FIXEDGLO
  440. # undef GLOB
  441. # define GLOB(x) (DsGlo->x)
  442. #endif
  443. }
  444.  
  445.  
  446. /***************************************************************
  447. ** NAME:        DsMakeDefine
  448. ** SYNOPSIS:    void DsMakeDefine();
  449. ** DESCRIPTION: Evaluates a define statement.
  450. ** RETURNS:     void
  451. ***************************************************************/
  452. STATIC
  453. void PASCAL DsMakeDefine()
  454. {
  455.     CELP name;
  456.  
  457.     name=CARpart(item);                                    /* name= (sum x y) */
  458.     item=CDRpart(item);                                    /* item= ((+ x y)) */
  459.     if (ISATOM(name))                                          /* simple form */
  460.     {
  461.         item=CARpart(item);
  462.         DsEvalItem();
  463.     }
  464.     else
  465.     {
  466.         DsMakeProc(CDRpart(name));                  /* turn it into procedure */
  467.         name=CARpart(name);
  468.     }
  469.     DsDefVar(name);
  470.     item=name;                                /* return defined symbol */
  471. }
  472.  
  473.  
  474. /***************************************************************
  475. ** NAME:        DsMakeProc
  476. ** SYNOPSIS:    void DsMakeProc(formals)
  477. **              CELP formals
  478. ** DESCRIPTION: Combines the arguments of (Define ...) with the
  479. **              current environment into a special pair called
  480. **              TYPE_PRC. The car is the body, cdr is the env.
  481. **              ITEM input is body, ITEM output is proc.
  482. ** RETURNS:     Pointer to new cel with the procedure.
  483. ***************************************************************/
  484. STATIC
  485. void PASCAL DsMakeProc(formals)
  486. CELP formals;
  487. {
  488. #ifdef COMPILEBODY
  489.     CELP elem;
  490.     CELP curenv=GLOB(curenv);
  491.  
  492.     elem = DsBodyCheck(item); /* Body check changes curenv as a side effect!! */
  493.     item = DsCons( DsFormals(formals, 1),
  494.                    DsCons(elem, GLOB(curenv)));  /* Link extended environment */
  495.     TAGpart(item) = TYPE_PRC;                                 /* Special pair */
  496.     GLOB(curenv)=curenv;                     /* Restore to normal environment */
  497. #else
  498.     item = DsCons(DsFormals(formals, 1), DsCons(item, GLOB(curenv))); 
  499.     TAGpart(item) = TYPE_PRC;                                 /* Special pair */
  500. #endif
  501. }
  502.  
  503.  
  504. #ifdef COMPILEBODY
  505. /***************************************************************
  506. ** NAME:        DsBodyCheck
  507. ** SYNOPSIS:    CELP DsBodyCheck(body)
  508. **              CELP body;
  509. ** DESCRIPTION: Checks if a body starts with defines.
  510. **              If it is then the current environment is 
  511. **              extended to contain these defines.
  512. **              It destroys item and key.
  513. ** RETURNS:     Stripped body
  514. ***************************************************************/
  515. STATIC
  516. CELP PASCAL DsBodyCheck(body)
  517. CELP body;             /* Body such as ((define a 2) (+ a a)) */
  518. {
  519.     int flag=0;
  520.     
  521.     for (;body!=NIL;body=CDRpart(body))
  522.     {
  523.         CELP p;
  524.  
  525.         item=CARpart(body);             /* item is (define (sum x y) (+ x y)) */
  526.         if (TAG(item)!=TYPE_PAIR)                   /* It isn't an expression */
  527.             break;
  528.         p=CARpart(item);                       /* Get key of first expression */
  529.         if ((TAG(p)!=TYPE_KEY) || (KEYpart(p)!=IP_DEF))
  530.             break;
  531.         if (flag==0)                          /* Enviroment not yet extended? */
  532.         {
  533.             GLOB(curenv)=DsCons(DsCons1(NIL), GLOB(curenv));     /* new frame */
  534.             flag==1;
  535.         }
  536.         DsEvalItem();                                  /* Evaluate the define */
  537.     }
  538.     return body;                                     /* Return remaining body */
  539. }
  540. #endif
  541.  
  542.  
  543. /***************************************************************
  544. ** NAME:        DsMakeMacro
  545. ** SYNOPSIS:    void DsMakeMacro();
  546. ** DESCRIPTION: Converts a (macro ...) into a macro procedure.
  547. **              Input and output is in ITEM.
  548. ** RETURNS:     void
  549. ***************************************************************/
  550. STATIC
  551. void PASCAL DsMakeMacro()
  552. {
  553.     CELP name;                     /* On entry is item: ((when x y) (if x y)) */
  554.  
  555.     name = CAARpart(item);                                     /* name = when */
  556.     if (!ISSYM(name)) DSTERROR(name);
  557.     TAGpart(name) = TYPE_MAC;                /* Make this symbol a macro name */
  558.     CARpart(name) = DsCons( DsFormals(CDARpart(item),0),  /* make formal-list */
  559.                             CDRpart(item));                     /* ((if x y)) */
  560.     item=name;
  561. }
  562.  
  563.  
  564. /***************************************************************
  565. ** NAME:        DsFormals
  566. ** SYNOPSIS:    CELP DsFormals(list, dotted)
  567. **              CELP list;
  568. **              int dotted;
  569. ** DESCRIPTION: Converts a list of formals into a formal cell.
  570. **              This cell contains the list, the number of
  571. **              formals and a vararg flag.
  572. ** RETURNS:     void
  573. ***************************************************************/
  574. STATIC CELP PASCAL DsFormals(formals, dot)
  575. CELP formals;
  576. int dot;
  577. {
  578.     CELP p,q;
  579.     int dotted=FALSE, len=0;
  580.     
  581.     q=NIL;
  582.     p=formals;
  583.     while (p!=NIL)
  584.     {
  585.         len++;
  586.         if (TAGpart(p)!=TYPE_PAIR)
  587.         {
  588.             dotted=VARARG;
  589.             if (ISTRUE(q))
  590.                 CDRpart(q)=dot?p:DsCons1(p);     /* Add last item to the list */
  591.             break;
  592.         }
  593.         if (CDRpart(p)==NIL)                              /* End of this list */
  594.         {
  595.             p=CARpart(p);
  596.             if (!dot) p=DsCons1(p);
  597.             if (ISTRUE(q))
  598.                 CDRpart(q)=p;                    /* Add last item to the list */
  599.             else
  600.                 formals=p;                 /* Get the first and only argument */
  601.             break;
  602.         }
  603.         if (ISTRUE(q))
  604.             q=CDRpart(q)=DsCons1(CARpart(p));
  605.         else
  606.             formals=q=DsCons1(CARpart(p));
  607.         p=CDRpart(p);
  608.     }
  609.     p=DsGetCell(TYPE_FUN);
  610.     CDRpart(p)=formals;    
  611.     KEYpart(p)=dotted;
  612.     ARGpart(p)=len;
  613.     return p;
  614. }
  615.  
  616.  
  617. /***************************************************************
  618. ** NAME:        DsReplace
  619. ** SYNOPSIS:    CELP DsReplace(expr)
  620. **              CELP expr;
  621. ** DESCRIPTION: Copies a expression, while replacing all symbols
  622. **              indicated by 'DsReplace_symbols', by the new
  623. **              values stored in 'DsReplace_newvals'.
  624. ** RETURNS:     Pointer to new expression
  625. ***************************************************************/
  626. STATIC
  627. CELP PASCAL DsReplace(expr)
  628. CELP expr;
  629. {
  630.     if (ISNIL(expr)) return NIL;
  631.     switch (TAGpart(expr))
  632.     {
  633.     case TYPE_PAIR:
  634.         return DsCons( DsReplace(CARpart(expr)),
  635.                        DsReplace(CDRpart(expr)));
  636.     case TYPE_SYMD:
  637.     case TYPE_SYM:
  638.         {
  639.             static CELP p,q;            /* they don't have to be on the stack */
  640.             p=walker;
  641.             q=item;
  642.             while (ISTRUE(p))
  643.             {
  644.                 if (CARpart(p)==expr)                       /* found a symbol */
  645.                     return(CARpart(q));            /* replace it by new value */
  646.                 p=CDRpart(p);
  647.                 q=CDRpart(q);
  648.             }
  649.         }
  650.     }
  651.     return(expr);                                 /* don't have to replace it */
  652. }
  653.  
  654.  
  655. /***************************************************************
  656. ** NAME:        DsValues
  657. ** SYNOPSIS:    int DsValues(void);
  658. ** DESCRIPTION: This function evaluates each element of the list
  659. **              of arguments. Input and output is ITEM.
  660. ** RETURNS:     number of arguments.
  661. ***************************************************************/
  662. STATIC
  663. int PASCAL DsValues(mode)
  664. int mode;
  665. {
  666.     if (ISNIL(item))
  667.     {
  668.         GLOB(curargs)=NIL;
  669.         return 0;
  670.     }
  671.     else
  672.     {
  673.         int len=1;
  674.         CELP cp,args=item;                /* These must be on the stack! */
  675.  
  676.         if (TAGpart(args)!=TYPE_PAIR) DSTERROR(args);
  677.         item=CARpart(args);                      /* Get argument from list */
  678.         DsEvalItem();                            /* Evaluate item */ 
  679.         args=CDRpart(args);                      /* Goto next argument */
  680.         if (mode)                                /* Build a normal list */
  681.         {
  682.             GLOB(curargs)=cp=DsCons1(item);      /* Store first value */
  683.             while (ISTRUE(args)) 
  684.             {
  685.                 if (TAGpart(args)!=TYPE_PAIR) DSTERROR(args);
  686.                 item=CARpart(args);               /* Get argument from list */
  687.                 DsEvalItem();                     /* Evaluate item */ 
  688.                 cp=CDRpart(cp)=DsCons1(item);
  689.                 args=CDRpart(args);               /* Goto next argument */
  690.                 len++;
  691.             }
  692.         }       
  693.         else
  694.         {
  695.             if (ISNIL(args))       /* End of list, so there is one arg */
  696.             {
  697.                 GLOB(curargs)=cp=item;
  698.                 return 1;
  699.             }
  700.             GLOB(curargs)=cp=DsCons1(item);   /* Store first value */
  701.             len=2;
  702.             while (1)
  703.             {
  704.                 /* dotted args lists are not implemented... */
  705.                 if (TAGpart(args)!=TYPE_PAIR) DSTERROR(args);
  706.                 item=CARpart(args);           /* Get argument from list */
  707.                 DsEvalItem();                 /* Evaluate item */ 
  708.                 args=CDRpart(args);           /* Goto next argument */
  709.                 if (ISNIL(args)) break;       /* No more args, break */
  710.                 cp=CDRpart(cp)=DsCons1(item); /* Store middle values */
  711.                 len++;
  712.             }
  713.             cp=CDRpart(cp)=item;              /* Store last value */
  714.         }
  715.         item=GLOB(curargs);
  716.         return len;
  717.     }
  718. }
  719.  
  720.  
  721. /**************************************************************
  722. ** NAME:        DsSearchFrame
  723. ** SYNOPSIS:    int DsSearchFrame(p)
  724. **              CELP p;
  725. ** DESCRIPTION: Search in frame pointed by p, for the cel in
  726. **              which <item> is bound. 
  727. ** RETURNS:     True, value is in item 
  728. **              False, none found.
  729. **************************************************************/
  730. STATIC
  731. int PASCAL DsSearchFrame(p)
  732. CELP p;
  733. {
  734.     static CELP fp;                        /* Doesn't have to be on the stack */
  735.  
  736.     p=CARpart(p);                                       /* Point to the frame */
  737.     for (fp=CARpart(p); ISPAIR(fp); fp=CDRpart(fp))
  738.     {
  739.         p=CDRpart(p);
  740.         if (CARpart(fp)==item)
  741.         {
  742.             item = CARpart(p);               /* Found it */
  743.             return TRUE;
  744.         }
  745.     }
  746.     if (fp==item)
  747.     {
  748.         item=CDRpart(p);
  749.         return TRUE;
  750.     }
  751.     return FALSE; 
  752. }
  753.  
  754.  
  755. /**************************************************************
  756. ** NAME:        DsSetFrame
  757. ** SYNOPSIS:    int DsSetFrame(p, name)
  758. **              CELP p;
  759. **              CELP name;
  760. ** DESCRIPTION: Search in frame pointed by <p> for <name>. 
  761. **              If it is found it is bound to <item>.
  762. ** RETURNS:     TRUE, name found and bound to item.
  763. **              FALSE, name not found,
  764. **************************************************************/
  765. STATIC
  766. int PASCAL DsSetFrame(p,name)
  767. CELP p;
  768. CELP name;
  769. {
  770.     static CELP fp;                        /* Doesn't have to be on the stack */
  771.  
  772.     p=CARpart(p);                /* Point to the frame itself */
  773.     for (fp=CARpart(p); ISPAIR(fp); fp=CDRpart(fp))  /* Walk list of formals */
  774.     {
  775.         p=CDRpart(p);
  776.         if (CARpart(fp)==name)
  777.         {
  778.             CARpart(p)=item;
  779.             return TRUE;
  780.         }
  781.     }
  782.     if (fp==name)
  783.     {
  784.         CDRpart(p)=item;
  785.         return TRUE;
  786.     }
  787.     return FALSE;
  788. }
  789.  
  790.  
  791. /***************************************************************
  792. ** NAME:        DsLookup
  793. ** SYNOPSIS:    CELP DsLookup();
  794. ** DESCRIPTION: Finds the symbol ITEM in the current environment
  795. **              Calls DSERROR if symbol isn't defined.
  796. ** RETURNS:     Pointer to value of symbol.
  797. ***************************************************************/
  798. STATIC
  799. void PASCAL DsLookup()
  800. {
  801.     static CELP q;                         /* Doesn't have to be on the stack */
  802.  
  803.     /* Search environment first */
  804.     for (q=GLOB(curenv); ISTRUE(q); q=CDRpart(q))
  805.         if (DsSearchFrame(q))
  806.            return;
  807.     switch(TAGpart(item))                                    /* Special cases */
  808.     {
  809.     case TYPE_KEY: return;
  810.     case TYPE_SYMD: item=CARpart(item);return;
  811.     }
  812.     DSERROR(ERRSYM,item);                                      /* Not found ! */
  813. }
  814.  
  815.  
  816. /***************************************************************
  817. ** NAME:        DsDefVar
  818. ** SYNOPSIS:    void DsDefVar(name)
  819. **              CELP name;      symbol to be defined.
  820. ** DESCRIPTION: Defines the symbol in the current environment.
  821. **              If the symbol already exists, the new value is
  822. **              bound to it. The value is passed via ITEM.
  823. ** RETURNS:     void
  824. ***************************************************************/
  825. void PASCAL DsDefVar(name)
  826. CELP name;
  827. {
  828.     if (!ISSYM(name)) DSTERROR(name);
  829.     switch(TAG(item))                                  /* Check special cases */
  830.     {
  831.     case TYPE_MAC:
  832.         TAGpart(name)=TYPE_MAC;
  833.         CARpart(name)=CARpart(item);                 /* copy macro definition */
  834.         return;
  835.  
  836.     case TYPE_KEY:
  837.         TAGpart(name)=TYPE_KEY;
  838.         KEYpart(name)=KEYpart(item);                   /* copy keyword number */
  839.         ARGpart(name)=ARGpart(item);
  840.         return;
  841.     }
  842.     if (GLOB(curenv)==GLOB(sysenv))                     /* We're at top level */
  843.     {
  844.         TAGpart(name)=TYPE_SYMD;                          /* a defined symbol */
  845.         CARpart(name)=item;                                  /* bind to value */
  846.     }
  847.     else
  848.     {
  849.         if (TAGpart(name)!=TYPE_SYMD)
  850.             TAGpart(name)=TYPE_SYM;           /* it's now defined as a symbol */
  851.         if (!DsSetFrame(GLOB(curenv), name))         /* Not in current frame? */
  852.         {
  853.             static CELP p;
  854.         
  855.             p=CARpart(GLOB(curenv));        /* extend environment */
  856.             if (ISNIL(CARpart(p)))
  857.             {
  858.                     CARpart(p)=name;
  859.                     CDRpart(p)=item;
  860.             }
  861.             else
  862.             {
  863.                     CARpart(p)=DsCons(name,CARpart(p));
  864.                     CDRpart(p)=DsCons(item,CDRpart(p));
  865.             }
  866.         }
  867.     }
  868. }
  869.  
  870.  
  871. /***************************************************************
  872. ** NAME:        DsSetVar
  873. ** SYNOPSIS:    void DsSetVar(name)
  874. **              CELP name;      symbol to be set.
  875. ** DESCRIPTION: Rebounds the symbol with the new value stored
  876. **              in ITEM. Returns the bound value in ITEM.
  877. **              If the symbol doesn't exists, DsError is called.
  878. ** RETURNS:     Returns the bound value.
  879. ***************************************************************/
  880. STATIC
  881. void PASCAL DsSetVar(name)
  882. CELP name;
  883. {
  884.     if (!ISSYM(name)) DSTERROR(name);
  885.     switch(TAG(item))                                  /* Check special cases */
  886.     {
  887.     case TYPE_MAC:
  888.         TAGpart(name)=TYPE_MAC;
  889.         CARpart(name)=CARpart(item);                 /* copy macro definition */
  890.         return;
  891.  
  892.     case TYPE_KEY:
  893.         TAGpart(name)=TYPE_KEY;
  894.         KEYpart(name)=KEYpart(item);                   /* copy keyword number */
  895.         ARGpart(name)=ARGpart(item);                   /* copy number of args */
  896.         return;
  897.     }
  898.     /* default */
  899.     {
  900.         static CELP env;                   /* Doesn't have to be on the stack */
  901.         for (env=GLOB(curenv); ISTRUE(env); env=CDRpart(env))
  902.         {
  903.             if (DsSetFrame(env, name))            /* Search and bind if found */
  904.             {
  905.                 if (TAGpart(name)!=TYPE_SYMD)
  906.                     TAGpart(name)=TYPE_SYM;   /* it's now defined as a symbol */
  907.                 return;                                    /* Found and bound */
  908.             }
  909.         }                                         /* not found in environment */
  910.         if (TAGpart(name)!=TYPE_SYMD)                 /* defined in toplevel? */
  911.             DSERROR(ERRSYM,name);    /* Oops, we can only set defined symbols */
  912.         CARpart(name)=item;                       /* redefine toplevel symbol */
  913.     }
  914. }
  915.  
  916.  
  917. /**************************************************************
  918. ** NAME:        DsVarArg
  919. ** SYNOPSIS:    void DsVarArg()
  920. ** DESCRIPTION: Rebuilds a list of arguments of a lambda call
  921. **              with dotted list of formals to a simple list.
  922. ** RETURNS:     void
  923. **************************************************************/
  924. STATIC
  925. void PASCAL DsVarArg()
  926. {
  927.     if (!ISPAIR(item))
  928.         item=DsCons1(item);
  929.     else
  930.     {
  931.         static CELP p,q;
  932.         q=item;
  933.         for (p=CDRpart(q); ISPAIR(p); p=CDRpart(p))
  934.             q=p;
  935.         CDRpart(q)=DsCons1(p);
  936.     }
  937. }
  938.  
  939.  
  940. /***************************************************************
  941. ** NAME:        DsCallExternal
  942. ** SYNOPSIS:    CELP DsCallExternal(ArgLen);
  943. **              int ArgLen;
  944. ** DESCRIPTION: Calls an user supplied C-procedure.
  945. **              This procedure can be linked to DScheme via the
  946. **              DSextdef function.
  947. **              KEY points to key cell.
  948. ** RETURNS:     The result of the external function
  949. ** SEE ALSO:    DSextdef
  950. ***************************************************************/
  951. typedef CELP (* FUNC0) __((void));      /* external defined procedures */
  952. typedef CELP (* FUNC2) __((CELP,CELP)); /* external defined procedures */
  953. typedef CELP (* FUNC3) __((CELP,CELP,CELP)); /* external defined procs */
  954. typedef CELP (* FUNCN) __((int,CELP));  /* external defined procedures */
  955. typedef CELP (* FUNC1) __((CELP));      /* external defined procedures */
  956.  
  957. STATIC
  958. CELP PASCAL DsCallExternal(ArgLen)
  959. int ArgLen;
  960. {
  961.     register EXTDEF *extdef;
  962.  
  963.     extdef=CELEXT(key);
  964.     if (extdef->args==-1)                /* don't want to check on arg count? */
  965.         return ((FUNCN)extdef->extrn)(ArgLen,item);
  966.     if (extdef->args==ArgLen)                              /* check arg count */
  967.     {
  968.         static CELP arg1, arg2;                  /* static's are not on stack */
  969.         switch(extdef->args)
  970.         {
  971.         case 0:
  972.             return ((FUNC0)extdef->extrn)();
  973.         case 1:
  974.             if (extdef->at1) TYPCHECK(item,extdef->at1);
  975.             return ((FUNC1)extdef->extrn)(item);
  976.         case 2:
  977.             arg1=CARpart(item);
  978.             item=CDRpart(item);
  979.             if (extdef->at1) TYPCHECK(arg1,extdef->at1);
  980.             if (extdef->at2) TYPCHECK(item,extdef->at2);
  981.             return ((FUNC2)extdef->extrn)(arg1, item);
  982.         case 3:
  983.             arg1=CARpart(item);item=CDRpart(item);
  984.             arg2=CARpart(item);
  985.             item=CDRpart(item);
  986.             if (extdef->at1) TYPCHECK(arg1,extdef->at1);
  987.             if (extdef->at2) TYPCHECK(arg2,extdef->at2);
  988.             if (extdef->at3) TYPCHECK(item,extdef->at3);
  989.             return ((FUNC3)extdef->extrn)(arg1,arg2,item);
  990.         }
  991.     }
  992.     DSERROR(ERRARC,key);
  993. }
  994.  
  995.  
  996. /***************************************************************
  997. ** NAME:        DsApplyKernel
  998. ** SYNOPSIS:    CELP DsApplyKernel();
  999. ** DESCRIPTION: This function applies the procedure on the
  1000. **              given arguments. Input via ITEM and KEY.
  1001. ** RETURNS:     The result value
  1002. ***************************************************************/
  1003. STATIC
  1004. CELP PASCAL DsApplyKernel(ArgLen)
  1005. int ArgLen;
  1006. {               
  1007.     switch(ARGpart(key))
  1008.     {
  1009.     case 1:
  1010.         return Ds_math1(KEYpart(key),GLOB(curargs));
  1011.  
  1012.     case 2:
  1013.         {
  1014.             CELP q=CDRpart(GLOB(curargs));
  1015.             item=CARpart(GLOB(curargs));
  1016.             switch(KEYpart(key))
  1017.             {
  1018.             case IP_CHARLT  : return DsCmpChar(q,item,2);
  1019.             case IP_CHARLE  : return DsCmpChar(q,item,1);
  1020.             case IP_CHAREQ  : return DsCmpChar(item,q,0);
  1021.             case IP_CHARGE  : return DsCmpChar(item,q,1);
  1022.             case IP_CHARGT  : return DsCmpChar(item,q,2);
  1023.             case IP_CHARLTCI  : return DsCmpChar(q,item,6);
  1024.             case IP_CHARLECI  : return DsCmpChar(q,item,5);
  1025.             case IP_CHAREQCI  : return DsCmpChar(item,q,4);
  1026.             case IP_CHARGECI  : return DsCmpChar(item,q,5);
  1027.             case IP_CHARGTCI  : return DsCmpChar(item,q,6);
  1028.             case IP_SETCAR  : CARpart(item)=q; return item;
  1029.             case IP_SETCDR  : CDRpart(item)=q; return item;                      
  1030.             case IP_ASSQ    : return DsAssQ(item,q);
  1031.             case IP_ASSV    : return DsAssV(item,q);
  1032.             case IP_ASSOC   : return DsAssoc(item,q);
  1033.             case IP_EQ      : return TEST(item==q);
  1034.             case IP_EQV     : return DsEqv(item,q);
  1035.             case IP_EQUAL   : return DsEqual(item,q);
  1036.             case IP_MEMQ    : return DsMemQ(item,q);
  1037.             case IP_MEMV    : return DsMemV(item,q);
  1038.             case IP_MEMBER  : return DsMember(item,q);
  1039.             case IP_TIMEEQ  : return DsCmpTime(item,q,0);
  1040.             case IP_TIMELE  : return DsCmpTime(q,item,1);
  1041.             case IP_TIMELT  : return DsCmpTime(q,item,2);
  1042.             case IP_TIMEGE  : return DsCmpTime(item,q,-1);
  1043.             case IP_TIMEGT  : return DsCmpTime(item,q,-2);
  1044.             }
  1045.         }
  1046.     }
  1047.     DSERROR(ERRNOT,key);
  1048. }
  1049.  
  1050.