home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / symbol.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  21.3 KB  |  566 lines
  1. # Funktionen betr. Symbole für CLISP
  2. # Bruno Haible 22.4.1995
  3.  
  4. #include "lispbibl.c"
  5.  
  6.  
  7. #if 0 # unbenutzt
  8. # UP: Liefert die globale Funktionsdefinition eines Symbols,
  9. # mit Test, ob das Symbol eine globale Funktion darstellt.
  10. # Symbol_function_checked(symbol)
  11. # > symbol: Symbol
  12. # < ergebnis: seine globale Funktionsdefinition
  13.   global object Symbol_function_checked (object symbol);
  14.   global object Symbol_function_checked(symbol)
  15.     var reg1 object symbol;
  16.     { var reg2 object fun = Symbol_function(symbol);
  17.       if (eq(fun,unbound))
  18.         { pushSTACK(symbol); # Wert für Slot NAME von CELL-ERROR
  19.           pushSTACK(symbol);
  20.           pushSTACK(S(symbol_function));
  21.           //: DEUTSCH "~: ~ hat keine globale Funktionsdefinition."
  22.           //: ENGLISH "~: ~ has no global function definition"
  23.           //: FRANCAIS "~ : ~ n'a pas de définition globale de fonction."
  24.           fehler(undefined_function, GETTEXT("~: ~ has no global function definition"));
  25.         }
  26.       if (consp(fun))
  27.         { pushSTACK(symbol);
  28.           pushSTACK(S(function));
  29.           //: DEUTSCH "~: ~ ist ein Macro und keine Funktion."
  30.           //: ENGLISH "~: ~ is a macro, not a function"
  31.           //: FRANCAIS "~ : ~ est une macro et non une fonction."
  32.           fehler(error, GETTEXT("~: ~ is a macro, not a function"));
  33.         }
  34.       return fun;
  35.     }
  36. #endif
  37.  
  38. # Fehlermeldung, wenn ein Symbol eine Property-Liste ungerader Länge hat.
  39. # fehler_plist_odd(symbol);
  40. # > symbol: Symbol
  41.   nonreturning_function(local, fehler_plist_odd, (object symbol));
  42.   local void fehler_plist_odd(symbol)
  43.     var reg1 object symbol;
  44.     { pushSTACK(symbol);
  45.       pushSTACK(S(get));
  46.       //: DEUTSCH "~: Die Property-Liste von ~ hat ungerade Länge."
  47.       //: ENGLISH "~: the property list of ~ has an odd length"
  48.       //: FRANCAIS "~ : La liste de propriétés attachée à ~ est de longueur impaire."
  49.       fehler(error, GETTEXT("~: the property list of ~ has an odd length"));
  50.     }
  51.  
  52. # UP: Holt eine Property aus der Property-Liste eines Symbols.
  53. # get(symbol,key)
  54. # > symbol: ein Symbol
  55. # > key: ein mit EQ zu vergleichender Key
  56. # < value: dazugehöriger Wert aus der Property-Liste von symbol, oder unbound.
  57.   global object get (object symbol, object key);
  58.   global object get(symbol,key)
  59.     var reg3 object symbol;
  60.     var reg2 object key;
  61.     { var reg1 object plistr = Symbol_plist(symbol);
  62.       loop
  63.         { if (atomp(plistr)) goto notfound;
  64.           if (eq(Car(plistr),key)) goto found;
  65.           plistr = Cdr(plistr);
  66.           if (atomp(plistr)) goto odd;
  67.           plistr = Cdr(plistr);
  68.         }
  69.       found: # key gefunden
  70.         plistr = Cdr(plistr);
  71.         if (atomp(plistr)) goto odd;
  72.         return Car(plistr);
  73.       odd: # Property-Liste hat ungerade Länge
  74.         fehler_plist_odd(symbol);
  75.       notfound: # key nicht gefunden
  76.         return unbound;
  77.     }
  78.  
  79. LISPFUNN(putd,2)
  80. # (SYS::%PUTD symbol function)
  81.   { var reg2 object symbol = STACK_1;
  82.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  83.    {var reg1 object fun = STACK_0;
  84.     # fun muß SUBR, FSUBR, Closure oder (SYS::MACRO . Closure) sein,
  85.     # Lambda-Ausdruck wird sofort in eine Closure umgewandelt:
  86.     if (subrp(fun) || closurep(fun) || fsubrp(fun)) goto ok;
  87.     elif (consp(fun)) # ein Cons?
  88.       { if (eq(Car(fun),S(macro)))
  89.           { if (mclosurep(Cdr(fun))) goto ok; } # (SYS::MACRO . Closure) ist ok
  90.         elif (eq(Car(fun),S(lambda)))
  91.           { var reg3 object lambdabody = Cdr(fun); # (lambda-list {decl|doc} . body)
  92.             # leeres Environment für get_closure:
  93.             pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL);
  94.            {var reg4 environment* env = &STACKblock_(environment,0);
  95.             fun = get_closure(lambdabody,symbol,env); # Closure erzeugen
  96.             skipSTACK(5);
  97.             goto ok;
  98.       }   }}
  99.     elif (ffunctionp(fun)) goto ok; # Foreign-Function ist auch ok.
  100.     pushSTACK(fun);
  101.     //: DEUTSCH "SETF SYMBOL-FUNCTION: ~ ist keine Funktion."
  102.     //: ENGLISH "SETF SYMBOL-FUNCTION: ~ is not a function"
  103.     //: FRANCAIS "SETF SYMBOL-FUNCTION : ~ n'est pas une fonction."
  104.     fehler(error, GETTEXT("SETF SYMBOL-FUNCTION: ~ is not a function"));
  105.     ok: # fun korrekt, in die Funktionszelle stecken:
  106.     value1 = popSTACK(); # function-Argument als Wert
  107.     Symbol_function(popSTACK()) = fun;
  108.     mv_count=1;
  109.   }}
  110.  
  111. LISPFUNN(proclaim_constant,2)
  112. # (SYS::%PROCLAIM-CONSTANT symbol value) erklärt ein Symbol zu einer Konstanten
  113. # und ihm einen Wert zu.
  114.   { var reg2 object val = popSTACK();
  115.     var reg1 object symbol = popSTACK();
  116.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  117.     set_const_flag(TheSymbol(symbol)); # symbol zu einer Konstanten machen
  118.     set_Symbol_value(symbol,val); # ihren Wert setzen
  119.     value1 = symbol; mv_count=1; # symbol als Wert
  120.   }
  121.  
  122. LISPFUN(get,2,1,norest,nokey,0,NIL)
  123. # (GET symbol key [not-found]), CLTL S. 164
  124.   { var reg2 object symbol = STACK_2;
  125.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  126.    {var reg1 object result = get(symbol,STACK_1); # suchen
  127.     if (eq(result,unbound)) # nicht gefunden?
  128.       { result = STACK_0; # Defaultwert ist not-found
  129.         if (eq(result,unbound)) # Ist der nicht angegeben,
  130.           { result = NIL; } # dann NIL.
  131.       }
  132.     value1 = result; mv_count=1;
  133.     skipSTACK(3);
  134.   }}
  135.  
  136. LISPFUN(getf,2,1,norest,nokey,0,NIL)
  137. # (GETF place key [not-found]), CLTL S. 166
  138.   { var reg1 object plistr = STACK_2;
  139.     var reg2 object key = STACK_1;
  140.     loop
  141.       { if (atomp(plistr)) goto notfound;
  142.         if (eq(Car(plistr),key)) goto found;
  143.         plistr = Cdr(plistr);
  144.         if (atomp(plistr)) goto odd;
  145.         plistr = Cdr(plistr);
  146.       }
  147.     found: # key gefunden
  148.       plistr = Cdr(plistr);
  149.       if (atomp(plistr)) goto odd;
  150.       value1 = Car(plistr); mv_count=1; skipSTACK(3); return;
  151.     odd: # Property-Liste hat ungerade Länge
  152.     { pushSTACK(STACK_2);
  153.       pushSTACK(S(getf));
  154.       //: DEUTSCH "~: Die Property-Liste ~ hat ungerade Länge."
  155.       //: ENGLISH "~: the property list ~ has an odd length"
  156.       //: FRANCAIS "~ : La liste de propriétés ~ est de longueur impaire."
  157.       fehler(error, GETTEXT("~: the property list ~ has an odd length"));
  158.     }
  159.     notfound: # key nicht gefunden
  160.       if (eq( value1 = STACK_0, unbound)) # Defaultwert ist not-found
  161.         { value1 = NIL; } # Ist der nicht angegeben, dann NIL.
  162.       mv_count=1; skipSTACK(3); return;
  163.   }
  164.  
  165. LISPFUNN(get_properties,2)
  166. # (GET-PROPERTIES place keylist), CLTL S. 167
  167.   { var reg4 object keylist = popSTACK();
  168.     var reg5 object plist = popSTACK();
  169.     var reg3 object plistr = plist;
  170.     loop
  171.       { if (atomp(plistr)) goto notfound;
  172.        {var reg2 object item = Car(plistr);
  173.         var reg1 object keylistr = keylist;
  174.         while (consp(keylistr))
  175.           { if (eq(item,Car(keylistr))) goto found;
  176.             keylistr = Cdr(keylistr);
  177.           }
  178.         plistr = Cdr(plistr);
  179.         if (atomp(plistr)) goto odd;
  180.         plistr = Cdr(plistr);
  181.       }}
  182.     found: # key gefunden
  183.       value3 = plistr; # Dritter Wert = Listenrest
  184.       value1 = Car(plistr); # Erster Wert = gefundener Key
  185.       plistr = Cdr(plistr);
  186.       if (atomp(plistr)) goto odd;
  187.       value2 = Car(plistr); # Zweiter Wert = Wert zum Key
  188.       mv_count=3; return; # Drei Werte
  189.     odd: # Property-Liste hat ungerade Länge
  190.     { pushSTACK(plist);
  191.       pushSTACK(S(get_properties));
  192.       //: DEUTSCH "~: Die Property-Liste ~ hat ungerade Länge."
  193.       //: ENGLISH "~: the property list ~ has an odd length"
  194.       //: FRANCAIS "~ : La liste de propriétés ~ est de longueur impaire."
  195.       fehler(error, GETTEXT("~: the property list ~ has an odd length"));
  196.     }
  197.     notfound: # key nicht gefunden
  198.       value1 = value2 = value3 = NIL; mv_count=3; return; # alle 3 Werte NIL
  199.   }
  200.  
  201. LISPFUNN(putplist,2)
  202. # (SYS::%PUTPLIST symbol list) == (SETF (SYMBOL-PLIST symbol) list)
  203.   { var reg2 object list = popSTACK();
  204.     var reg1 object symbol = popSTACK();
  205.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  206.     value1 = Symbol_plist(symbol) = list; mv_count=1;
  207.   }
  208.  
  209. LISPFUNN(put,3)
  210. # (SYS::%PUT symbol key value) == (SETF (GET symbol key) value)
  211.   { { var reg3 object symbol = STACK_2;
  212.       if (!symbolp(symbol)) { fehler_symbol(symbol); }
  213.      {var reg2 object key = STACK_1;
  214.       var reg1 object plistr = Symbol_plist(symbol);
  215.       loop
  216.         { if (atomp(plistr)) goto notfound;
  217.           if (eq(Car(plistr),key)) goto found;
  218.           plistr = Cdr(plistr);
  219.           if (atomp(plistr)) goto odd;
  220.           plistr = Cdr(plistr);
  221.         }
  222.       found: # key gefunden
  223.         plistr = Cdr(plistr);
  224.         if (atomp(plistr)) goto odd;
  225.         value1 = Car(plistr) = STACK_0; mv_count=1; # neues value eintragen
  226.         skipSTACK(3); return;
  227.       odd: # Property-Liste hat ungerade Länge
  228.         fehler_plist_odd(symbol);
  229.     }}
  230.     notfound: # key nicht gefunden
  231.     # Property-Liste um 2 Conses erweitern:
  232.     pushSTACK(allocate_cons());
  233.     { var reg2 object cons1 = allocate_cons();
  234.       var reg1 object cons2 = popSTACK();
  235.       value1 = Car(cons2) = popSTACK(); # value
  236.       Car(cons1) = popSTACK(); # key
  237.      {var reg3 object symbol = popSTACK();
  238.       Cdr(cons2) = Symbol_plist(symbol);
  239.       Cdr(cons1) = cons2;
  240.       Symbol_plist(symbol) = cons1;
  241.       mv_count=1; return;
  242.     }}
  243.   }
  244.  
  245. LISPFUNN(remprop,2)
  246. # (REMPROP symbol indicator), CLTL S. 166
  247.   { var reg3 object key = popSTACK();
  248.     var reg4 object symbol = popSTACK();
  249.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  250.    {var reg2 object* plistr_ = &Symbol_plist(symbol);
  251.     var reg1 object plistr;
  252.     loop
  253.       { plistr = *plistr_;
  254.         if (atomp(plistr)) goto notfound;
  255.         if (eq(Car(plistr),key)) goto found;
  256.         plistr = Cdr(plistr);
  257.         if (atomp(plistr)) goto odd;
  258.         plistr_ = &Cdr(plistr);
  259.       }
  260.     found: # key gefunden
  261.       plistr = Cdr(plistr);
  262.       if (atomp(plistr)) goto odd;
  263.       *plistr_ = Cdr(plistr); # Property-Liste um 2 Elemente verkürzen
  264.       value1 = T; mv_count=1; return; # Wert T
  265.     odd: # Property-Liste hat ungerade Länge
  266.       fehler_plist_odd(symbol);
  267.     notfound: # key nicht gefunden
  268.       value1 = NIL; mv_count=1; return; # Wert NIL
  269.   }}
  270.  
  271. LISPFUNN(symbol_package,1)
  272. # (SYMBOL-PACKAGE symbol), CLTL S. 170
  273.   { var reg1 object symbol = popSTACK();
  274.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  275.     value1 = Symbol_package(symbol); mv_count=1;
  276.   }
  277.  
  278. LISPFUNN(symbol_plist,1)
  279. # (SYMBOL-PLIST symbol), CLTL S. 166
  280.   { var reg1 object symbol = popSTACK();
  281.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  282.     value1 = Symbol_plist(symbol); mv_count=1;
  283.   }
  284.  
  285. LISPFUNN(symbol_name,1)
  286. # (SYMBOL-NAME symbol), CLTL S. 168
  287.   { var reg1 object symbol = popSTACK();
  288.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  289.     value1 = Symbol_name(symbol); mv_count=1;
  290.   }
  291.  
  292. LISPFUNN(keywordp,1)
  293. # (KEYWORDP object), CLTL S. 170
  294.   { var reg1 object obj = popSTACK();
  295.     if (symbolp(obj) && keywordp(obj))
  296.       { value1 = T; }
  297.       else
  298.       { value1 = NIL; }
  299.     mv_count=1;
  300.   }
  301.  
  302. LISPFUNN(special_variable_p,1)
  303. # (SYS::SPECIAL-VARIABLE-P symbol) stellt fest, ob das Symbol eine
  304. # Special-Variable (oder eine Konstante) darstellt.
  305. # (Bei Konstanten ist ja das Special-Bit bedeutungslos.)
  306.   { var reg1 object symbol = popSTACK();
  307.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  308.     value1 = (constantp(TheSymbol(symbol)) || special_var_p(TheSymbol(symbol))
  309.               ? T : NIL
  310.              );
  311.     mv_count=1;
  312.   }
  313.  
  314. LISPFUN(gensym,0,1,norest,nokey,0,NIL)
  315. # (GENSYM x), CLTL S. 169, CLtL2 S. 245-246
  316. # (defun gensym (&optional (x nil s))
  317. #   (let ((prefix "G") ; ein String
  318. #         (counter *gensym-counter*)) ; ein Integer >=0
  319. #     (when s
  320. #       (cond ((stringp x) (setq prefix x))
  321. #             ((integerp x)
  322. #              (if (minusp x)
  323. #                (error-of-type 'type-error
  324. #                       :datum x :expected-type '(INTEGER 0 *)
  325. #                       #+DEUTSCH "~S: Index ~S ist negativ."
  326. #                       #+ENGLISH "~S: index ~S is negative"
  327. #                       #+FRANCAIS "~S: L'index ~S est négatif."
  328. #                       'gensym x
  329. #                )
  330. #                (setq counter x)
  331. #             ))
  332. #             (t (error-of-type 'type-error
  333. #                       :datum x :expected-type '(OR STRING INTEGER)
  334. #                       #+DEUTSCH "~S: Argument ~S hat falschen Typ"
  335. #                       #+ENGLISH "~S: invalid argument ~S"
  336. #                       #+FRANCAIS "~S: L'argument ~S n'est pas du bon type."
  337. #                       'gensym x
  338. #             )  )
  339. #     ) )
  340. #     (prog1
  341. #       (make-symbol
  342. #         (string-concat
  343. #           prefix
  344. #           #-CLISP (write-to-string counter :base 10 :radix nil)
  345. #           #+CLISP (sys::decimal-string counter)
  346. #       ) )
  347. #       (unless (integerp x) (setq *gensym-counter* (1+ counter)))
  348. # ) ) )
  349.   { var reg3 object prefix = O(gensym_prefix); # "G"
  350.     var reg2 object counter = Symbol_value(S(gensym_counter)); # *GENSYM-COUNTER*
  351.     var reg1 object x = popSTACK(); # Argument
  352.     if (!eq(x,unbound))
  353.       # x angegeben
  354.       { if (stringp(x))
  355.           { prefix = x; } # prefix setzen
  356.         elif (integerp(x))
  357.           { if (R_minusp(x))
  358.               { pushSTACK(x); # Wert für Slot DATUM von TYPE-ERROR
  359.                 pushSTACK(O(type_posinteger)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  360.                 pushSTACK(x);
  361.                 pushSTACK(S(gensym));
  362.                 //: DEUTSCH "~: Index ~ ist negativ."
  363.                 //: ENGLISH "~: index ~ is negative"
  364.                 //: FRANCAIS "~ : L'index ~ est négatif."
  365.                 fehler(type_error, GETTEXT("~: index ~ is negative"));
  366.               }
  367.             # x ist ein Integer >=0
  368.             counter = x; # counter setzen
  369.           }
  370.         else
  371.           { pushSTACK(x); # Wert für Slot DATUM von TYPE-ERROR
  372.             pushSTACK(O(type_gensym_arg)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  373.             pushSTACK(x);
  374.             pushSTACK(S(gensym));
  375.             //: DEUTSCH "~: Argument ~ hat falschen Typ."
  376.             //: ENGLISH "~: invalid argument ~"
  377.             //: FRANCAIS "~ : L'argument ~ n'est pas du bon type."
  378.             fehler(type_error, GETTEXT("~: invalid argument ~"));
  379.       }   }
  380.     # String zusammenbauen:
  381.     pushSTACK(prefix); # 1. Teilstring
  382.     pushSTACK(counter); # counter
  383.     if (!integerp(x))
  384.       { if (!(integerp(counter) && !R_minusp(counter))) # sollte Integer >= 0 sein
  385.           { var reg4 object new_value = Fixnum_0; # *GENSYM-COUNTER* zurücksetzen
  386.             set_Symbol_value(S(gensym_counter),new_value);
  387.             pushSTACK(counter); # Wert für Slot DATUM von TYPE-ERROR
  388.             pushSTACK(O(type_posinteger)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  389.             pushSTACK(new_value); pushSTACK(counter);
  390.             //: DEUTSCH "Der Wert von *GENSYM-COUNTER* war kein Integer >= 0. Alter Wert: ~. Neuer Wert: ~."
  391.             //: ENGLISH "The value of *GENSYM-COUNTER* was not a nonnegative integer. Old value ~. New value ~."
  392.             //: FRANCAIS "La valeur de *GENSYM-COUNTER* n'était pas un entier >= 0. Ancienne valeur : ~. Nouvelle valeur : ~."
  393.             fehler(type_error, GETTEXT("The value of *GENSYM-COUNTER* was not a nonnegative integer. Old value ~. New value ~."));
  394.           }
  395.         set_Symbol_value(S(gensym_counter),I_1_plus_I(counter)); # (incf *GENSYM-COUNTER*)
  396.       }
  397.     funcall(L(decimal_string),1); # (sys::decimal-string counter)
  398.     pushSTACK(value1); # 2. String
  399.     value1 = make_symbol(string_concat(2)); # zusammenhängen, Symbol bilden
  400.     mv_count=1; # als Wert
  401.   }
  402.  
  403. #ifdef DYNBIND_LIST
  404.  
  405. #if 0
  406. local int _find_symbol_in_frame (object sym,object *stackptr);
  407. local int _find_symbol_in_frame (sym,stackptr)
  408.   var object sym;
  409.   var object *stackptr;
  410.   { var reg4 object frameinfo = *stackptr;
  411.     var reg3 object* new_STACK = topofframe(frameinfo);
  412.     var reg2 object* frame_end = STACKpointable(new_STACK);
  413.     var reg1 object* bindingptr = stackptr STACKop 1;
  414.    
  415.     if (!(typecode(frameinfo) == DYNBIND_frame_info)) abort();
  416.     until (bindingptr == frame_end)
  417.       { if (eq(*(bindingptr STACKop 0),sym))
  418.           { value1 = *(bindingptr STACKop 1);
  419.             return TRUE;
  420.           }
  421.         bindingptr skipSTACKop 2;
  422.       }
  423.     return FALSE;
  424.   }
  425.  
  426. local int _find_binding (object sym);
  427. local int _find_binding (sym)
  428.   var object sym;
  429.   { 
  430.     { var reg1 object obj = Symbol_symvalue(S(dynamic_bindings));
  431.       var reg2 object item;
  432.       loop 
  433.         {
  434.           if (!consp(obj)) break;
  435.           item = Car(obj);
  436.           # if (systemp(item))
  437.             { if (_find_symbol_in_frame(sym,uTheFramepointer(item))) 
  438.                 return TRUE;
  439.             }
  440.         }
  441.     }
  442.     { var reg1 object obj = Symbol_symvalue(S(special_bindings));
  443.       var reg2 object item;
  444.       loop 
  445.         {
  446.           if (!consp(obj)) break;
  447.           item = Car(obj);
  448.           # if (consp(item))
  449.             { if (eq(Car(item),sym))
  450.                 { value1 = Cdr(item);
  451.                   return TRUE;
  452.                 }
  453.             }
  454.           obj = Cdr(obj);
  455.         }
  456.     }
  457.     return FALSE;
  458.   }
  459.  
  460. #endif
  461.  
  462.  
  463. local object add_frame_to_frame_list (object *stackptr);
  464. local object add_frame_to_frame_list (stackptr)
  465.   var object *stackptr;
  466.   {
  467.     pushSTACK(allocate_cons());
  468.     Car(STACK_0)=make_framepointer(stackptr);
  469.     Cdr(STACK_0)=Symbol_symvalue(S(dynamic_and_special_frames));
  470.     set_Symbol_symvalue(S(dynamic_and_special_frames),STACK_0);
  471.     return popSTACK();
  472.   }
  473.  
  474. global void add_frame_to_binding_list (object *stackptr);
  475. global void add_frame_to_binding_list(stackptr)
  476.   var object *stackptr;
  477.   { 
  478.     pushSTACK(allocate_cons());
  479.     Car(STACK_0)=add_frame_to_frame_list(stackptr);
  480.     Cdr(STACK_0)=Symbol_symvalue(S(dynamic_bindings));
  481.     set_Symbol_symvalue(S(dynamic_bindings),STACK_0);
  482.     if (!eq(Symbol_symvalue(S(last_binding_type)),S(Kdynamic)))
  483.       { pushSTACK(allocate_cons());
  484.         Car(STACK_0)=STACK_1;
  485.         Cdr(STACK_0)=Symbol_symvalue(S(transitions_to_dynamic_bindings));
  486.         set_Symbol_symvalue(S(transitions_to_dynamic_bindings),STACK_0);
  487.         skipSTACK(1);
  488.       }
  489.     set_Symbol_symvalue(S(last_binding_type),S(Kdynamic));
  490.     skipSTACK(1);
  491.   }
  492.  
  493. global void delete_frame_from_binding_list (object *stackptr);
  494. global void delete_frame_from_binding_list(stackptr)
  495.   var reg9 object *stackptr;
  496.   {
  497.     var reg8 object dynamic_bindings = Symbol_symvalue(S(dynamic_bindings));
  498.     var reg7 object special_transition_list = Symbol_symvalue(S(transitions_to_special_bindings));
  499.     var reg6 object dynamic_transition_list = Symbol_symvalue(S(transitions_to_dynamic_bindings));
  500.     var reg5 object special_list = Car(special_transition_list);
  501.     var reg4 object dynamic_list = Car(dynamic_transition_list);
  502.     var reg3 object last_special_frame_cons = Car(special_list);
  503.     var reg2 object last_dynamic_frame_cons = Car(dynamic_list);
  504.     var reg1 object frame_cons = Car(dynamic_bindings);
  505.     if (eq(Cdr(last_special_frame_cons),frame_cons))
  506.       { Cdr(last_special_frame_cons) = Cdr(frame_cons);
  507.         set_Symbol_symvalue(S(transitions_to_special_bindings),Cdr(special_transition_list));
  508.       }
  509.     else set_Symbol_symvalue(S(dynamic_and_special_frames),Cdr(Symbol_symvalue(S(dynamic_and_special_frames))));
  510.     if (eq(last_dynamic_frame_cons,frame_cons))
  511.       { Cdr(last_dynamic_frame_cons) = Cdr(frame_cons);
  512.         set_Symbol_symvalue(S(transitions_to_dynamic_bindings),Cdr(dynamic_transition_list));
  513.       }
  514.     set_Symbol_symvalue(S(dynamic_bindings),Cdr(dynamic_bindings));
  515.   }
  516.  
  517. global void set_Symbolflagged_value_on (object sym,object val,object *frame_ptr);
  518. global void set_Symbolflagged_value_on (sym,val,frame_ptr)
  519.   var reg5 object sym;
  520.   var reg4 object val;
  521.   var reg3 object *frame_ptr;
  522.   {
  523.      set_Symbolflagged_symvalue(sym,val);
  524.      pushSTACK(allocate_cons());
  525.      Car(STACK_0) = add_frame_to_frame_list(frame_ptr);
  526.      Cdr(STACK_0) = Symbol_symvalue(S(special_bindings));
  527.      set_Symbol_symvalue(S(special_bindings),STACK_0);
  528.      if (!eq(Symbol_symvalue(S(last_binding_type)),S(Kspecial)))
  529.       { pushSTACK(allocate_cons());
  530.         Car(STACK_0)=STACK_1;
  531.         Cdr(STACK_0)=Symbol_symvalue(S(transitions_to_special_bindings));
  532.         set_Symbol_symvalue(S(transitions_to_special_bindings),STACK_0);
  533.         skipSTACK(1);
  534.       }
  535.      set_Symbol_symvalue(S(last_binding_type),S(Kspecial));
  536.      skipSTACK(1);
  537.   }
  538.  
  539. global void set_Symbolflagged_value_off (object sym,object val);
  540. global void set_Symbolflagged_value_off (sym,val)
  541.   var reg10 object sym;
  542.   var reg9 object val;
  543.   {
  544.     var reg8 object special_bindings = Symbol_symvalue(S(special_bindings));
  545.     var reg7 object special_transition_list = Symbol_symvalue(S(transitions_to_special_bindings));
  546.     var reg6 object dynamic_transition_list = Symbol_symvalue(S(transitions_to_dynamic_bindings));
  547.     var reg5 object dynamic_list = Car(dynamic_transition_list);
  548.     var reg4 object special_list = Car(special_transition_list);
  549.     var reg3 object last_dynamic_frame_cons = Car(dynamic_list);
  550.     var reg2 object last_special_frame_cons = Car(special_list);
  551.     var reg1 object frame_cons = Car(special_bindings);
  552.     if (eq(Cdr(last_dynamic_frame_cons),frame_cons))
  553.       { Cdr(last_dynamic_frame_cons) = Cdr(frame_cons);
  554.         set_Symbol_symvalue(S(transitions_to_dynamic_bindings),Cdr(dynamic_transition_list));
  555.       }
  556.     else set_Symbol_symvalue(S(dynamic_and_special_frames),Cdr(Symbol_symvalue(S(dynamic_and_special_frames))));
  557.     if (eq(last_special_frame_cons,frame_cons))
  558.       { Cdr(last_special_frame_cons) = Cdr(frame_cons);
  559.         set_Symbol_symvalue(S(transitions_to_special_bindings),Cdr(special_transition_list));
  560.       }
  561.     set_Symbol_symvalue(S(special_bindings),Cdr(special_bindings));
  562.     set_Symbolflagged_symvalue(sym,val);
  563.   }
  564.  
  565. #endif
  566.