home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / symbol.d < prev    next >
Encoding:
Text File  |  1993-12-16  |  14.2 KB  |  403 lines
  1. # Funktionen betr. Symbole fⁿr CLISP
  2. # Bruno Haible 16.12.1993
  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.           fehler(undefined_function,
  22.                  DEUTSCH ? "~: ~ hat keine globale Funktionsdefinition." :
  23.                  ENGLISH ? "~: ~ has no global function definition" :
  24.                  FRANCAIS ? "~ : ~ n'a pas de dΘfinition globale de fonction." :
  25.                  ""
  26.                 );
  27.         }
  28.       if (consp(fun))
  29.         { pushSTACK(symbol);
  30.           pushSTACK(S(function));
  31.           fehler(error,
  32.                  DEUTSCH ? "~: ~ ist ein Macro und keine Funktion." :
  33.                  ENGLISH ? "~: ~ is a macro, not a function" :
  34.                  FRANCAIS ? "~ : ~ est une macro et non une fonction." :
  35.                  ""
  36.                 );
  37.         }
  38.       return fun;
  39.     }
  40. #endif
  41.  
  42. # Fehlermeldung, wenn ein Symbol eine Property-Liste ungerader LΣnge hat.
  43. # fehler_plist_odd(symbol);
  44. # > symbol: Symbol
  45.   nonreturning_function(local, fehler_plist_odd, (object symbol));
  46.   local void fehler_plist_odd(symbol)
  47.     var reg1 object symbol;
  48.     { pushSTACK(symbol);
  49.       pushSTACK(S(get));
  50.       fehler(error,
  51.              DEUTSCH ? "~: Die Property-Liste von ~ hat ungerade LΣnge." :
  52.              ENGLISH ? "~: the property list of ~ has an odd length" :
  53.              FRANCAIS ? "~ : La liste de propriΘtΘs attachΘe α ~ est de longueur impaire." :
  54.              ""
  55.             );
  56.     }
  57.  
  58. # UP: Holt eine Property aus der Property-Liste eines Symbols.
  59. # get(symbol,key)
  60. # > symbol: ein Symbol
  61. # > key: ein mit EQ zu vergleichender Key
  62. # < value: dazugeh÷riger Wert aus der Property-Liste von symbol, oder unbound.
  63.   global object get (object symbol, object key);
  64.   global object get(symbol,key)
  65.     var reg3 object symbol;
  66.     var reg2 object key;
  67.     { var reg1 object plistr = Symbol_plist(symbol);
  68.       loop
  69.         { if (atomp(plistr)) goto notfound;
  70.           if (eq(Car(plistr),key)) goto found;
  71.           plistr = Cdr(plistr);
  72.           if (atomp(plistr)) goto odd;
  73.           plistr = Cdr(plistr);
  74.         }
  75.       found: # key gefunden
  76.         plistr = Cdr(plistr);
  77.         if (atomp(plistr)) goto odd;
  78.         return Car(plistr);
  79.       odd: # Property-Liste hat ungerade LΣnge
  80.         fehler_plist_odd(symbol);
  81.       notfound: # key nicht gefunden
  82.         return unbound;
  83.     }
  84.  
  85. LISPFUNN(putd,2)
  86. # (SYS::%PUTD symbol function)
  87.   { var reg2 object symbol = STACK_1;
  88.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  89.    {var reg1 object fun = STACK_0;
  90.     # fun mu▀ SUBR, FSUBR, Closure oder (SYS::MACRO . Closure) sein,
  91.     # Lambda-Ausdruck wird sofort in eine Closure umgewandelt:
  92.     if (subrp(fun) || closurep(fun) || fsubrp(fun)) goto ok;
  93.     if (consp(fun)) # ein Cons?
  94.       { if (eq(Car(fun),S(macro)))
  95.           { if (mclosurep(Cdr(fun))) goto ok; } # (SYS::MACRO . Closure) ist ok
  96.         elif (eq(Car(fun),S(lambda)))
  97.           { var reg3 object lambdabody = Cdr(fun); # (lambda-list {decl|doc} . body)
  98.             # leeres Environment fⁿr get_closure:
  99.             pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL);
  100.            {var reg4 environment* env = &STACKblock_(environment,0);
  101.             fun = get_closure(lambdabody,symbol,env); # Closure erzeugen
  102.             skipSTACK(5);
  103.             goto ok;
  104.       }   }}
  105.     pushSTACK(fun);
  106.     fehler(error,
  107.            DEUTSCH ? "SETF SYMBOL-FUNCTION: ~ ist keine Funktion." :
  108.            ENGLISH ? "SETF SYMBOL-FUNCTION: ~ is not a function" :
  109.            FRANCAIS ? "SETF SYMBOL-FUNCTION : ~ n'est pas une fonction." :
  110.            ""
  111.           );
  112.     ok: # fun korrekt, in die Funktionszelle stecken:
  113.     value1 = popSTACK(); # function-Argument als Wert
  114.     Symbol_function(popSTACK()) = fun;
  115.     mv_count=1;
  116.   }}
  117.  
  118. LISPFUNN(proclaim_constant,2)
  119. # (SYS::%PROCLAIM-CONSTANT symbol value) erklΣrt ein Symbol zu einer Konstanten
  120. # und ihm einen Wert zu.
  121.   { var reg2 object val = popSTACK();
  122.     var reg1 object symbol = popSTACK();
  123.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  124.     set_const_flag(TheSymbol(symbol)); # symbol zu einer Konstanten machen
  125.     Symbol_value(symbol) = val; # ihren Wert setzen
  126.     value1 = symbol; mv_count=1; # symbol als Wert
  127.   }
  128.  
  129. LISPFUN(get,2,1,norest,nokey,0,NIL)
  130. # (GET symbol key [not-found]), CLTL S. 164
  131.   { var reg2 object symbol = STACK_2;
  132.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  133.    {var reg1 object result = get(symbol,STACK_1); # suchen
  134.     if (eq(result,unbound)) # nicht gefunden?
  135.       { result = STACK_0; # Defaultwert ist not-found
  136.         if (eq(result,unbound)) # Ist der nicht angegeben,
  137.           { result = NIL; } # dann NIL.
  138.       }
  139.     value1 = result; mv_count=1;
  140.     skipSTACK(3);
  141.   }}
  142.  
  143. LISPFUN(getf,2,1,norest,nokey,0,NIL)
  144. # (GETF place key [not-found]), CLTL S. 166
  145.   { var reg1 object plistr = STACK_2;
  146.     var reg2 object key = STACK_1;
  147.     loop
  148.       { if (atomp(plistr)) goto notfound;
  149.         if (eq(Car(plistr),key)) goto found;
  150.         plistr = Cdr(plistr);
  151.         if (atomp(plistr)) goto odd;
  152.         plistr = Cdr(plistr);
  153.       }
  154.     found: # key gefunden
  155.       plistr = Cdr(plistr);
  156.       if (atomp(plistr)) goto odd;
  157.       value1 = Car(plistr); mv_count=1; skipSTACK(3); return;
  158.     odd: # Property-Liste hat ungerade LΣnge
  159.     { pushSTACK(STACK_2);
  160.       pushSTACK(S(getf));
  161.       fehler(error,
  162.              DEUTSCH ? "~: Die Property-Liste ~ hat ungerade LΣnge." :
  163.              ENGLISH ? "~: the property list ~ has an odd length" :
  164.              FRANCAIS ? "~ : La liste de propriΘtΘs ~ est de longueur impaire." :
  165.              ""
  166.             );
  167.     }
  168.     notfound: # key nicht gefunden
  169.       if (eq( value1 = STACK_0, unbound)) # Defaultwert ist not-found
  170.         { value1 = NIL; } # Ist der nicht angegeben, dann NIL.
  171.       mv_count=1; skipSTACK(3); return;
  172.   }
  173.  
  174. LISPFUNN(get_properties,2)
  175. # (GET-PROPERTIES place keylist), CLTL S. 167
  176.   { var reg4 object keylist = popSTACK();
  177.     var reg5 object plist = popSTACK();
  178.     var reg3 object plistr = plist;
  179.     loop
  180.       { if (atomp(plistr)) goto notfound;
  181.        {var reg2 object item = Car(plistr);
  182.         var reg1 object keylistr = keylist;
  183.         while (consp(keylistr))
  184.           { if (eq(item,Car(keylistr))) goto found;
  185.             keylistr = Cdr(keylistr);
  186.           }
  187.         plistr = Cdr(plistr);
  188.         if (atomp(plistr)) goto odd;
  189.         plistr = Cdr(plistr);
  190.       }}
  191.     found: # key gefunden
  192.       value3 = plistr; # Dritter Wert = Listenrest
  193.       value1 = Car(plistr); # Erster Wert = gefundener Key
  194.       plistr = Cdr(plistr);
  195.       if (atomp(plistr)) goto odd;
  196.       value2 = Car(plistr); # Zweiter Wert = Wert zum Key
  197.       mv_count=3; return; # Drei Werte
  198.     odd: # Property-Liste hat ungerade LΣnge
  199.     { pushSTACK(plist);
  200.       pushSTACK(S(get_properties));
  201.       fehler(error,
  202.              DEUTSCH ? "~: Die Property-Liste ~ hat ungerade LΣnge." :
  203.              ENGLISH ? "~: the property list ~ has an odd length" :
  204.              FRANCAIS ? "~ : La liste de propriΘtΘs ~ est de longueur impaire." :
  205.              ""
  206.             );
  207.     }
  208.     notfound: # key nicht gefunden
  209.       value1 = value2 = value3 = NIL; mv_count=3; return; # alle 3 Werte NIL
  210.   }
  211.  
  212. LISPFUNN(putplist,2)
  213. # (SYS::%PUTPLIST symbol list) == (SETF (SYMBOL-PLIST symbol) list)
  214.   { var reg2 object list = popSTACK();
  215.     var reg1 object symbol = popSTACK();
  216.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  217.     value1 = Symbol_plist(symbol) = list; mv_count=1;
  218.   }
  219.  
  220. LISPFUNN(put,3)
  221. # (SYS::%PUT symbol key value) == (SETF (GET symbol key) value)
  222.   { { var reg3 object symbol = STACK_2;
  223.       if (!symbolp(symbol)) { fehler_symbol(symbol); }
  224.      {var reg2 object key = STACK_1;
  225.       var reg1 object plistr = Symbol_plist(symbol);
  226.       loop
  227.         { if (atomp(plistr)) goto notfound;
  228.           if (eq(Car(plistr),key)) goto found;
  229.           plistr = Cdr(plistr);
  230.           if (atomp(plistr)) goto odd;
  231.           plistr = Cdr(plistr);
  232.         }
  233.       found: # key gefunden
  234.         plistr = Cdr(plistr);
  235.         if (atomp(plistr)) goto odd;
  236.         value1 = Car(plistr) = STACK_0; mv_count=1; # neues value eintragen
  237.         skipSTACK(3); return;
  238.       odd: # Property-Liste hat ungerade LΣnge
  239.         fehler_plist_odd(symbol);
  240.     }}
  241.     notfound: # key nicht gefunden
  242.     # Property-Liste um 2 Conses erweitern:
  243.     pushSTACK(allocate_cons());
  244.     { var reg2 object cons1 = allocate_cons();
  245.       var reg1 object cons2 = popSTACK();
  246.       value1 = Car(cons2) = popSTACK(); # value
  247.       Car(cons1) = popSTACK(); # key
  248.      {var reg3 object symbol = popSTACK();
  249.       Cdr(cons2) = Symbol_plist(symbol);
  250.       Cdr(cons1) = cons2;
  251.       Symbol_plist(symbol) = cons1;
  252.       mv_count=1; return;
  253.     }}
  254.   }
  255.  
  256. LISPFUNN(remprop,2)
  257. # (REMPROP symbol indicator), CLTL S. 166
  258.   { var reg3 object key = popSTACK();
  259.     var reg4 object symbol = popSTACK();
  260.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  261.    {var reg2 object* plistr_ = &Symbol_plist(symbol);
  262.     var reg1 object plistr;
  263.     loop
  264.       { plistr = *plistr_;
  265.         if (atomp(plistr)) goto notfound;
  266.         if (eq(Car(plistr),key)) goto found;
  267.         plistr = Cdr(plistr);
  268.         if (atomp(plistr)) goto odd;
  269.         plistr_ = &Cdr(plistr);
  270.       }
  271.     found: # key gefunden
  272.       plistr = Cdr(plistr);
  273.       if (atomp(plistr)) goto odd;
  274.       *plistr_ = Cdr(plistr); # Property-Liste um 2 Elemente verkⁿrzen
  275.       value1 = T; mv_count=1; return; # Wert T
  276.     odd: # Property-Liste hat ungerade LΣnge
  277.       fehler_plist_odd(symbol);
  278.     notfound: # key nicht gefunden
  279.       value1 = NIL; mv_count=1; return; # Wert NIL
  280.   }}
  281.  
  282. LISPFUNN(symbol_package,1)
  283. # (SYMBOL-PACKAGE symbol), CLTL S. 170
  284.   { var reg1 object symbol = popSTACK();
  285.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  286.     value1 = Symbol_package(symbol); mv_count=1;
  287.   }
  288.  
  289. LISPFUNN(symbol_plist,1)
  290. # (SYMBOL-PLIST symbol), CLTL S. 166
  291.   { var reg1 object symbol = popSTACK();
  292.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  293.     value1 = Symbol_plist(symbol); mv_count=1;
  294.   }
  295.  
  296. LISPFUNN(symbol_name,1)
  297. # (SYMBOL-NAME symbol), CLTL S. 168
  298.   { var reg1 object symbol = popSTACK();
  299.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  300.     value1 = Symbol_name(symbol); mv_count=1;
  301.   }
  302.  
  303. LISPFUNN(keywordp,1)
  304. # (KEYWORDP object), CLTL S. 170
  305.   { var reg1 object obj = popSTACK();
  306.     if (symbolp(obj) && keywordp(obj))
  307.       { value1 = T; }
  308.       else
  309.       { value1 = NIL; }
  310.     mv_count=1;
  311.   }
  312.  
  313. LISPFUNN(special_variable_p,1)
  314. # (SYS::SPECIAL-VARIABLE-P symbol) stellt fest, ob das Symbol eine
  315. # Special-Variable (oder eine Konstante) darstellt.
  316. # (Bei Konstanten ist ja das Special-Bit bedeutungslos.)
  317.   { var reg1 object symbol = popSTACK();
  318.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  319.     value1 = (constantp(TheSymbol(symbol)) || special_var_p(TheSymbol(symbol))
  320.               ? T : NIL
  321.              );
  322.     mv_count=1;
  323.   }
  324.  
  325. LISPFUN(gensym,0,1,norest,nokey,0,NIL)
  326. # (GENSYM x), CLTL S. 169
  327. # (let ((gensym-prefix "G") ; ein String
  328. #       (gensym-count 1)) ; ein Integer >=0
  329. #   (defun gensym (&optional (x nil s))
  330. #     (when s
  331. #       (cond ((stringp x) (setq gensym-prefix x))
  332. #             ((integerp x)
  333. #              (if (minusp x)
  334. #                (error-of-type 'type-error
  335. #                       :datum x :expected-type '(INTEGER 0 *)
  336. #                       #+DEUTSCH "~S: Index ~S ist negativ."
  337. #                       #+ENGLISH "~S: index ~S is negative"
  338. #                       #+FRANCAIS "~S: L'index ~S est nΘgatif."
  339. #                       'gensym x
  340. #                )
  341. #                (setq gensym-count x)
  342. #             ))
  343. #             (t (error-of-type 'type-error
  344. #                       :datum x :expected-type '(OR STRING INTEGER)
  345. #                       #+DEUTSCH "~S: Argument ~S hat falschen Typ"
  346. #                       #+ENGLISH "~S: invalid argument ~S"
  347. #                       #+FRANCAIS "~S: L'argument ~S n'est pas du bon type."
  348. #                       'gensym x
  349. #             )  )
  350. #     ) )
  351. #     (prog1
  352. #       (make-symbol
  353. #         (string-concat
  354. #           gensym-prefix
  355. #           #-CLISP (write-to-string gensym-count :base 10 :radix nil)
  356. #           #+CLISP (sys::decimal-string gensym-count)
  357. #       ) )
  358. #       (setq gensym-count (1+ gensym-count))
  359. # ) ) )
  360.   { var reg1 object x = popSTACK(); # Argument
  361.     if (!eq(x,unbound))
  362.       # x angegeben
  363.       { if (stringp(x))
  364.           { O(gensym_prefix) = x; } # gensym-prefix setzen
  365.         elif (integerp(x))
  366.           { if (R_minusp(x))
  367.               { pushSTACK(x); # Wert fⁿr Slot DATUM von TYPE-ERROR
  368.                 pushSTACK(O(type_posinteger)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  369.                 pushSTACK(x);
  370.                 pushSTACK(S(gensym));
  371.                 fehler(type_error,
  372.                        DEUTSCH ? "~: Index ~ ist negativ." :
  373.                        ENGLISH ? "~: index ~ is negative" :
  374.                        FRANCAIS ? "~ : L'index ~ est nΘgatif." :
  375.                        ""
  376.                       );
  377.               }
  378.             # x ist ein Integer >=0
  379.             O(gensym_count) = x; # gensym-count setzen
  380.           }
  381.         else
  382.           { pushSTACK(x); # Wert fⁿr Slot DATUM von TYPE-ERROR
  383.             pushSTACK(O(type_gensym_arg)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  384.             pushSTACK(x);
  385.             pushSTACK(S(gensym));
  386.             fehler(type_error,
  387.                    DEUTSCH ? "~: Argument ~ hat falschen Typ." :
  388.                    ENGLISH ? "~: invalid argument ~" :
  389.                    FRANCAIS ? "~ : L'argument ~ n'est pas du bon type." :
  390.                    ""
  391.                   );
  392.       }   }
  393.     # String zusammenbauen:
  394.     pushSTACK(O(gensym_prefix)); # 1. Teilstring
  395.     pushSTACK(O(gensym_count)); # altes gensym-count
  396.     O(gensym_count) = I_1_plus_I(O(gensym_count)); # (incf gensym-count)
  397.     funcall(L(decimal_string),1); # (sys::decimal-string gensym-count)
  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.