home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / defs2.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-07-23  |  14.4 KB  |  360 lines
  1. ;;; CLtL2-kompatible Definitionen
  2. ;;; Bruno Haible 21.7.1994
  3.  
  4. ;===============================================================================
  5.  
  6. (in-package "LISP")
  7. (export '(nth-value function-lambda-expression defpackage define-symbol-macro
  8.           print-unreadable-object declaim destructuring-bind
  9. )        )
  10. (in-package "SYSTEM")
  11.  
  12. ;-------------------------------------------------------------------------------
  13.  
  14. ;; X3J13 vote <123>
  15.  
  16. ;; Macro (nth-value n form) == (nth n (multiple-value-list form)), CLtL2 S. 184
  17. (defmacro nth-value (n form)
  18.   (if (and (integerp n) (>= n 0))
  19.     (if (< n (1- multiple-values-limit))
  20.       (if (= n 0)
  21.         `(PROG1 ,form)
  22.         (let ((resultvar (gensym)))
  23.           (do ((vars (list resultvar))
  24.                (ignores nil)
  25.                (i n (1- i)))
  26.               ((zerop i)
  27.                `(MULTIPLE-VALUE-BIND ,vars ,form
  28.                   (DECLARE (IGNORE ,@ignores))
  29.                   ,resultvar
  30.               ) )
  31.             (let ((g (gensym))) (push g vars) (push g ignores))
  32.       ) ) )
  33.       `(PROGN ,form NIL)
  34.     )
  35.     `(NTH ,n (MULTIPLE-VALUE-LIST ,form))
  36. ) )
  37.  
  38. ;-------------------------------------------------------------------------------
  39.  
  40. ;; X3J13 vote <88>
  41.  
  42. ;; Interpretierte Funktion in Lambda-Ausdruck umwandeln, CLtL2 S. 682
  43. (defun function-lambda-expression (obj)
  44.   (cond ((and (compiled-function-p obj) (functionp obj)) ; SUBR oder compilierte Closure?
  45.          (values nil t nil)
  46.         )
  47.         ((sys::closurep obj) ; interpretierte Closure?
  48.          (values (cons 'LAMBDA (sys::%record-ref obj 1)) ; Lambda-Ausdruck ohne Docstring
  49.                  (vector ; Environment
  50.                          (sys::%record-ref obj 4) ; venv
  51.                          (sys::%record-ref obj 5) ; fenv
  52.                          (sys::%record-ref obj 6) ; benv
  53.                          (sys::%record-ref obj 7) ; genv
  54.                          (sys::%record-ref obj 8) ; denv
  55.                  )
  56.                  (sys::%record-ref obj 0) ; Name
  57.         ))
  58.         (t
  59.          (error-of-type 'type-error
  60.            :datum obj :expected-type 'function
  61.            (DEUTSCH "~S: ~S ist keine Funktion."
  62.             ENGLISH "~S: ~S is not a function"
  63.             FRANCAIS "~S : ~S n'est pas une fonction.")
  64.            'function-lambda-expression obj
  65. ) )     ))
  66.  
  67. ;-------------------------------------------------------------------------------
  68.  
  69. ;; X3J13 vote <52>
  70.  
  71. ;; Package-Definition und -Installation, CLtL2 S. 270
  72. (defmacro defpackage (packname &rest options)
  73.   (flet ((check-packname (name)
  74.            (cond ((stringp name) name)
  75.                  ((symbolp name) (symbol-name name))
  76.                  (t (error-of-type 'program-error
  77.                       (DEUTSCH "~S: Package-Name mu▀ ein String oder Symbol sein, nicht ~S."
  78.                        ENGLISH "~S: package name ~S should be a string or a symbol"
  79.                        FRANCAIS "~S : Le nom d'un paquetage doit Ωtre une chaεne ou un symbole et non ~S.")
  80.                       'defpackage name
  81.          ) )     )  )
  82.          (check-symname (name)
  83.            (cond ((stringp name) name)
  84.                  ((symbolp name) (symbol-name name))
  85.                  (t (error-of-type 'program-error
  86.                       (DEUTSCH "~S ~A: Symbol-Name mu▀ ein String oder Symbol sein, nicht ~S."
  87.                        ENGLISH "~S ~A: symbol name ~S should be a string or a symbol"
  88.                        FRANCAIS "~S ~A : Le nom d'un symbole doit Ωtre une chaεne ou un symbole et non ~S.")
  89.                       'defpackage packname name
  90.         )) )     )  )
  91.     (setq packname (check-packname packname))
  92.     ; Optionen abarbeiten:
  93.     (let ((size nil) ; Flag ob :SIZE schon da war
  94.           (documentation nil) ; Flag, ob :DOCUMENTATION schon da war
  95.           (nickname-list '()) ; Liste von Nicknames
  96.           (shadow-list '()) ; Liste von Symbolnamen fⁿr shadow
  97.           (shadowing-list '()) ; Listen von Paaren (Symbolname . Paketname) fⁿr shadowing-import
  98.           (use-list '()) ; Liste von Paketnamen fⁿr use-package
  99.           (use-default '("LISP")) ; Default-Wert fⁿr use-list
  100.           (import-list '()) ; Listen von Paaren (Symbolname . Paketname) fⁿr import
  101.           (intern-list '()) ; Liste von Symbolnamen fⁿr intern
  102.           (symname-list '()) ; Liste aller bisher aufgefⁿhrten Symbolnamen
  103.           (export-list '())) ; Liste von Symbolnamen fⁿr export
  104.       (flet ((record-symname (name)
  105.                (if (member name symname-list :test #'string=)
  106.                  (error-of-type 'program-error
  107.                    (DEUTSCH "~S ~A: Symbol ~A darf nur einmal aufgefⁿhrt werden."
  108.                     ENGLISH "~S ~A: the symbol ~A must not be specified more than once"
  109.                     FRANCAIS "~S ~A : Le symbole ~A ne peut Ωtre mentionnΘ qu'une seule fois.")
  110.                    'defpackage packname name
  111.                  )
  112.                  (push name symname-list)
  113.                )
  114.                name
  115.             ))
  116.         (dolist (option options)
  117.           (if (listp option)
  118.             (if (keywordp (car option))
  119.               (case (first option)
  120.                 (:SIZE
  121.                   (if size
  122.                     (error-of-type 'program-error
  123.                       (DEUTSCH "~S ~A: Die Option ~S darf nur einmal angegeben werden."
  124.                        ENGLISH "~S ~A: the ~S option must not be given more than once"
  125.                        FRANCAIS "~S ~A : L'option ~S ne doit apparaεtre qu'une seule fois.")
  126.                       'defpackage packname ':SIZE
  127.                     )
  128.                     (setq size t) ; Argument wird ignoriert
  129.                 ) )
  130.                 (:DOCUMENTATION ; dpANS
  131.                   (if documentation
  132.                     (error-of-type 'program-error
  133.                       (DEUTSCH "~S ~A: Die Option ~S darf nur einmal angegeben werden."
  134.                        ENGLISH "~S ~A: the ~S option must not be given more than once"
  135.                        FRANCAIS "~S ~A : L'option ~S ne doit apparaεtre qu'une seule fois.")
  136.                       'defpackage packname ':DOCUMENTATION
  137.                     )
  138.                     (setq documentation t) ; Argument wird ignoriert
  139.                 ) )
  140.                 (:NICKNAMES
  141.                   (dolist (name (rest option))
  142.                     (push (check-packname name) nickname-list)
  143.                 ) )
  144.                 (:SHADOW
  145.                   (dolist (name (rest option))
  146.                     (push (record-symname (check-symname name)) shadow-list)
  147.                 ) )
  148.                 (:SHADOWING-IMPORT-FROM
  149.                   (let ((pack (check-packname (second option))))
  150.                     (dolist (name (cddr option))
  151.                       (push (cons (record-symname (check-symname name)) pack)
  152.                             shadowing-list
  153.                 ) ) ) )
  154.                 (:USE
  155.                   (dolist (name (rest option))
  156.                     (push (check-packname name) use-list)
  157.                   )
  158.                   (setq use-default nil)
  159.                 )
  160.                 (:IMPORT-FROM
  161.                   (let ((pack (check-packname (second option))))
  162.                     (dolist (name (cddr option))
  163.                       (push (cons (record-symname (check-symname name)) pack)
  164.                             import-list
  165.                 ) ) ) )
  166.                 (:INTERN
  167.                   (dolist (name (rest option))
  168.                     (push (record-symname (check-symname name)) intern-list)
  169.                 ) )
  170.                 (:EXPORT
  171.                   (dolist (name (rest option))
  172.                     (push (check-symname name) export-list)
  173.                 ) )
  174.                 (T (error-of-type 'program-error
  175.                      (DEUTSCH "~S ~A: Die Option ~S gibt es nicht."
  176.                       ENGLISH "~S ~A: unknown option ~S"
  177.                       FRANCAIS "~S ~A : Option ~S non reconnue.")
  178.                      'defpackage packname (first option)
  179.               ) )  )
  180.               (error-of-type 'program-error
  181.                 (DEUTSCH "~S ~A: Falsche Syntax in ~S-Option: ~S"
  182.                  ENGLISH "~S ~A: invalid syntax in ~S option: ~S"
  183.                  FRANCAIS "~S ~A : Mauvaise syntaxe dans l'option ~S: ~S")
  184.                 'defpackage packname 'defpackage option
  185.             ) )
  186.             (error-of-type 'program-error
  187.               (DEUTSCH "~S ~A: Das ist keine ~S-Option: ~S"
  188.                ENGLISH "~S ~A: not a ~S option: ~S"
  189.                FRANCAIS "~S ~A : Ceci n'est pas une option ~S: ~S")
  190.               'defpackage packname 'defpackage option
  191.         ) ) )
  192.         ; Auf ▄berschneidungen zwischen intern-list und export-list prⁿfen:
  193.         (setq symname-list intern-list)
  194.         (mapc #'record-symname export-list)
  195.       )
  196.       ; Listen umdrehen und Default-Werte eintragen:
  197.       (setq nickname-list (nreverse nickname-list))
  198.       (setq shadow-list (nreverse shadow-list))
  199.       (setq shadowing-list (nreverse shadowing-list))
  200.       (setq use-list (or use-default (nreverse use-list)))
  201.       (setq import-list (nreverse import-list))
  202.       (setq intern-list (nreverse intern-list))
  203.       (setq export-list (nreverse export-list))
  204.       ; Expansion produzieren:
  205.       `(EVAL-WHEN (LOAD COMPILE EVAL)
  206.          (SYSTEM::%IN-PACKAGE ,packname :NICKNAMES ',nickname-list :USE '())
  207.          ; Schritt 1
  208.          ,@(if shadow-list
  209.              `((SHADOW ',(mapcar #'make-symbol shadow-list) ,packname))
  210.            )
  211.          ,@(mapcar
  212.              #'(lambda (pair)
  213.                  `(SHADOWING-IMPORT-CERROR ,(car pair) ,(cdr pair) ,packname)
  214.                )
  215.              shadowing-list
  216.            )
  217.          ; Schritt 2
  218.          ,@(if use-list `((USE-PACKAGE ',use-list ,packname)))
  219.          ; Schritt 3
  220.          ,@(mapcar
  221.              #'(lambda (pair)
  222.                  `(IMPORT-CERROR ,(car pair) ,(cdr pair) ,packname)
  223.                )
  224.              import-list
  225.            )
  226.          ,@(mapcar
  227.              #'(lambda (symname) `(INTERN ,symname ,packname))
  228.              intern-list
  229.            )
  230.          ; Schritt 4
  231.          ,@(if export-list
  232.              `((INTERN-EXPORT ',export-list ,packname))
  233.            )
  234.          (FIND-PACKAGE ,packname)
  235.        )
  236. ) ) )
  237. ; Hilfsfunktionen:
  238. (defun find-symbol-cerror (string packname calling-packname)
  239.   (multiple-value-bind (sym found) (find-symbol string packname)
  240.     (unless found
  241.       (cerror ; 'package-error ??
  242.               (DEUTSCH "Dieses Symbol wird erzeugt."
  243.                ENGLISH "This symbol will be created."
  244.                FRANCAIS "Ce symbole sera crΘΘ.")
  245.               (DEUTSCH "~S ~A: Es gibt kein Symbol ~A::~A ."
  246.                ENGLISH "~S ~A: There is no symbol ~A::~A ."
  247.                FRANCAIS "~S ~A : Il n'y a pas de symbole ~A::~A .")
  248.               'defpackage calling-packname packname string
  249.       )
  250.       (setq sym (intern string packname))
  251.     )
  252.     sym
  253. ) )
  254. (defun shadowing-import-cerror (string packname calling-packname)
  255.   (shadowing-import (find-symbol-cerror string packname calling-packname)
  256.                     calling-packname
  257. ) )
  258. (defun import-cerror (string packname calling-packname)
  259.   (import (find-symbol-cerror string packname calling-packname)
  260.           calling-packname
  261. ) )
  262. (defun intern-export (string-list packname)
  263.   (export (mapcar #'(lambda (string) (intern string packname)) string-list)
  264.           packname
  265. ) )
  266.  
  267. ;-------------------------------------------------------------------------------
  268.  
  269. ;; cf. X3J13 vote <173>
  270.  
  271. ;; Definition globaler Symbol-Macros
  272. (defmacro define-symbol-macro (symbol expansion)
  273.   (unless (symbolp symbol)
  274.     (error-of-type 'program-error
  275.       (DEUTSCH "~S: Der Name eines Symbol-Macros mu▀ ein Symbol sein, nicht: ~S"
  276.        ENGLISH "~S: the name of a symbol macro must be a symbol, not ~S"
  277.        FRANCAIS "~S : Le nom d'un macro symbole doit Ωtre un symbole et non ~S")
  278.       'define-symbol-macro symbol
  279.   ) )
  280.   `(LET ()
  281.      (EVAL-WHEN (COMPILE LOAD EVAL)
  282.        (CHECK-NOT-SPECIAL-VARIABLE-P ',symbol)
  283.        (SET ',symbol (SYSTEM::MAKE-SYMBOL-MACRO ',expansion))
  284.      )
  285.      ',symbol
  286.    )
  287. )
  288.  
  289. (defun check-not-special-variable-p (symbol)
  290.   (when (special-variable-p symbol)
  291.     (error-of-type 'error
  292.       (DEUTSCH "~S: Das Symbol ~S benennt eine globale Variable."
  293.        ENGLISH "~S: the symbol ~S names a global variable"
  294.        FRANCAIS "~S : Le symbole ~S est le nom d'une variable globale.")
  295.       'define-symbol-macro symbol
  296. ) ) )
  297.  
  298. ;-------------------------------------------------------------------------------
  299.  
  300. ;; X3J13 vote <40>
  301.  
  302. (defmacro print-unreadable-object
  303.     ((&whole args object stream &key type identity) &body body)
  304.   (declare (ignore object stream type identity))
  305.   `(SYSTEM::WRITE-UNREADABLE
  306.      ,(if body `(FUNCTION (LAMBDA () ,@body)) 'NIL)
  307.      ,@args
  308.    )
  309. )
  310.  
  311. ;-------------------------------------------------------------------------------
  312.  
  313. ;; X3J13 vote <144>
  314.  
  315. (defmacro declaim (&rest decl-specs)
  316.   `(PROGN
  317.      ,@(mapcar #'(lambda (decl-spec) `(PROCLAIM (QUOTE ,decl-spec))) decl-specs)
  318.    )
  319. )
  320.  
  321. ;-------------------------------------------------------------------------------
  322.  
  323. ;; X3J13 vote <64>
  324.  
  325. (defmacro destructuring-bind (lambdalist form &body body &environment env)
  326.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  327.     (if declarations (setq declarations `((DECLARE ,@declarations))))
  328.     (let ((%arg-count 0) (%min-args 0) (%restp nil)
  329.           (%let-list nil) (%keyword-tests nil) (%default-form nil))
  330.       (analyze1 lambdalist '<DESTRUCTURING-FORM> 'destructuring-bind '<DESTRUCTURING-FORM>)
  331.       (let ((lengthtest (make-length-test '<DESTRUCTURING-FORM> 0))
  332.             (mainform `(LET* ,(nreverse %let-list)
  333.                          ,@declarations
  334.                          ,@(nreverse %keyword-tests)
  335.                          ,@body-rest
  336.            ))          )
  337.         (if lengthtest
  338.           (setq mainform
  339.             `(IF ,lengthtest
  340.                (DESTRUCTURING-ERROR <DESTRUCTURING-FORM>
  341.                                     '(,%min-args . ,(if %restp nil %arg-count))
  342.                )
  343.                ,mainform
  344.         ) )  )
  345.         `(LET ((<DESTRUCTURING-FORM> ,form)) ,mainform)
  346. ) ) ) )
  347.  
  348. (defun destructuring-error (destructuring-form min.max)
  349.   (let ((min (car min.max))
  350.         (max (cdr min.max)))
  351.     (error-of-type 'error
  352.       (DEUTSCH "Das zu zerlegende Objekt sollte eine Liste mit ~:[mindestens ~*~S~;~:[~S bis ~S~;~S~]~] Elementen sein, nicht ~4@*~S."
  353.        ENGLISH "The object to be destructured should be a list with ~:[at least ~*~S~;~:[from ~S to ~S~;~S~]~] elements, not ~4@*~S."
  354.        FRANCAIS "L'objet α dΘmonter devrait Ωtre une liste ~:[d'au moins ~*~S~;de ~:[~S α ~S~;~S~]~] ΘlΘments et non ~4@*~S.")
  355.       max (eql min max) min max destructuring-form
  356. ) ) )
  357.  
  358. ;-------------------------------------------------------------------------------
  359.  
  360.