home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / src / defs2.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1995-06-17  |  17.7 KB  |  449 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 complement
  9.           constantly with-standard-io-syntax with-hash-table-iterator
  10. )        )
  11. (in-package "SYSTEM")
  12.  
  13. ;-------------------------------------------------------------------------------
  14.  
  15. ;; X3J13 vote <123>
  16.  
  17. ;; Macro (nth-value n form) == (nth n (multiple-value-list form)), CLtL2 S. 184
  18. (defmacro nth-value (n form)
  19.   (if (and (integerp n) (>= n 0))
  20.     (if (< n (1- multiple-values-limit))
  21.       (if (= n 0)
  22.         `(PROG1 ,form)
  23.         (let ((resultvar (gensym)))
  24.           (do ((vars (list resultvar))
  25.                (ignores nil)
  26.                (i n (1- i)))
  27.               ((zerop i)
  28.                `(MULTIPLE-VALUE-BIND ,vars ,form
  29.                   (DECLARE (IGNORE ,@ignores))
  30.                   ,resultvar
  31.               ) )
  32.             (let ((g (gensym))) (push g vars) (push g ignores))
  33.       ) ) )
  34.       `(PROGN ,form NIL)
  35.     )
  36.     `(NTH ,n (MULTIPLE-VALUE-LIST ,form))
  37. ) )
  38.  
  39. ;-------------------------------------------------------------------------------
  40.  
  41. ;; X3J13 vote <88>
  42.  
  43. ;; Interpretierte Funktion in Lambda-Ausdruck umwandeln, CLtL2 S. 682
  44. (defun function-lambda-expression (obj)
  45.   (cond ((and (compiled-function-p obj) (functionp obj)) ; SUBR oder compilierte Closure?
  46.          (values nil t nil)
  47.         )
  48.         ((sys::closurep obj) ; interpretierte Closure?
  49.          (values (cons 'LAMBDA (sys::%record-ref obj 1)) ; Lambda-Ausdruck ohne Docstring
  50.                  (vector ; Environment
  51.                          (sys::%record-ref obj 4) ; venv
  52.                          (sys::%record-ref obj 5) ; fenv
  53.                          (sys::%record-ref obj 6) ; benv
  54.                          (sys::%record-ref obj 7) ; genv
  55.                          (sys::%record-ref obj 8) ; denv
  56.                  )
  57.                  (sys::%record-ref obj 0) ; Name
  58.         ))
  59.         (t
  60.          (error-of-type 'type-error
  61.            :datum obj :expected-type 'function
  62.            (DEUTSCH "~S: ~S ist keine Funktion."
  63.             ENGLISH "~S: ~S is not a function"
  64.             FRANCAIS "~S : ~S n'est pas une fonction.")
  65.            'function-lambda-expression obj
  66. ) )     ))
  67.  
  68. ;-------------------------------------------------------------------------------
  69.  
  70. ;; X3J13 vote <52>
  71.  
  72. ;; Package-Definition und -Installation, CLtL2 S. 270
  73. (defmacro defpackage (packname &rest options)
  74.   (flet ((check-packname (name)
  75.            (cond ((stringp name) name)
  76.                  ((symbolp name) (symbol-name name))
  77.                  (t (error-of-type 'program-error
  78.                       (DEUTSCH "~S: Package-Name mu▀ ein String oder Symbol sein, nicht ~S."
  79.                        ENGLISH "~S: package name ~S should be a string or a symbol"
  80.                        FRANCAIS "~S : Le nom d'un paquetage doit Ωtre une chaεne ou un symbole et non ~S.")
  81.                       'defpackage name
  82.          ) )     )  )
  83.          (check-symname (name)
  84.            (cond ((stringp name) name)
  85.                  ((symbolp name) (symbol-name name))
  86.                  (t (error-of-type 'program-error
  87.                       (DEUTSCH "~S ~A: Symbol-Name mu▀ ein String oder Symbol sein, nicht ~S."
  88.                        ENGLISH "~S ~A: symbol name ~S should be a string or a symbol"
  89.                        FRANCAIS "~S ~A : Le nom d'un symbole doit Ωtre une chaεne ou un symbole et non ~S.")
  90.                       'defpackage packname name
  91.         )) )     )  )
  92.     (setq packname (check-packname packname))
  93.     ; Optionen abarbeiten:
  94.     (let ((size nil) ; Flag ob :SIZE schon da war
  95.           (documentation nil) ; Flag, ob :DOCUMENTATION schon da war
  96.           (nickname-list '()) ; Liste von Nicknames
  97.           (shadow-list '()) ; Liste von Symbolnamen fⁿr shadow
  98.           (shadowing-list '()) ; Listen von Paaren (Symbolname . Paketname) fⁿr shadowing-import
  99.           (use-list '()) ; Liste von Paketnamen fⁿr use-package
  100.           (use-default '("LISP")) ; Default-Wert fⁿr use-list
  101.           (import-list '()) ; Listen von Paaren (Symbolname . Paketname) fⁿr import
  102.           (intern-list '()) ; Liste von Symbolnamen fⁿr intern
  103.           (symname-list '()) ; Liste aller bisher aufgefⁿhrten Symbolnamen
  104.           (export-list '())) ; Liste von Symbolnamen fⁿr export
  105.       (flet ((record-symname (name)
  106.                (if (member name symname-list :test #'string=)
  107.                  (error-of-type 'program-error
  108.                    (DEUTSCH "~S ~A: Symbol ~A darf nur einmal aufgefⁿhrt werden."
  109.                     ENGLISH "~S ~A: the symbol ~A must not be specified more than once"
  110.                     FRANCAIS "~S ~A : Le symbole ~A ne peut Ωtre mentionnΘ qu'une seule fois.")
  111.                    'defpackage packname name
  112.                  )
  113.                  (push name symname-list)
  114.                )
  115.                name
  116.             ))
  117.         (dolist (option options)
  118.           (if (listp option)
  119.             (if (keywordp (car option))
  120.               (case (first option)
  121.                 (:SIZE
  122.                   (if size
  123.                     (error-of-type 'program-error
  124.                       (DEUTSCH "~S ~A: Die Option ~S darf nur einmal angegeben werden."
  125.                        ENGLISH "~S ~A: the ~S option must not be given more than once"
  126.                        FRANCAIS "~S ~A : L'option ~S ne doit apparaεtre qu'une seule fois.")
  127.                       'defpackage packname ':SIZE
  128.                     )
  129.                     (setq size t) ; Argument wird ignoriert
  130.                 ) )
  131.                 (:DOCUMENTATION ; dpANS
  132.                   (if documentation
  133.                     (error-of-type 'program-error
  134.                       (DEUTSCH "~S ~A: Die Option ~S darf nur einmal angegeben werden."
  135.                        ENGLISH "~S ~A: the ~S option must not be given more than once"
  136.                        FRANCAIS "~S ~A : L'option ~S ne doit apparaεtre qu'une seule fois.")
  137.                       'defpackage packname ':DOCUMENTATION
  138.                     )
  139.                     (setq documentation t) ; Argument wird ignoriert
  140.                 ) )
  141.                 (:NICKNAMES
  142.                   (dolist (name (rest option))
  143.                     (push (check-packname name) nickname-list)
  144.                 ) )
  145.                 (:SHADOW
  146.                   (dolist (name (rest option))
  147.                     (push (record-symname (check-symname name)) shadow-list)
  148.                 ) )
  149.                 (:SHADOWING-IMPORT-FROM
  150.                   (let ((pack (check-packname (second option))))
  151.                     (dolist (name (cddr option))
  152.                       (push (cons (record-symname (check-symname name)) pack)
  153.                             shadowing-list
  154.                 ) ) ) )
  155.                 (:USE
  156.                   (dolist (name (rest option))
  157.                     (push (check-packname name) use-list)
  158.                   )
  159.                   (setq use-default nil)
  160.                 )
  161.                 (:IMPORT-FROM
  162.                   (let ((pack (check-packname (second option))))
  163.                     (dolist (name (cddr option))
  164.                       (push (cons (record-symname (check-symname name)) pack)
  165.                             import-list
  166.                 ) ) ) )
  167.                 (:INTERN
  168.                   (dolist (name (rest option))
  169.                     (push (record-symname (check-symname name)) intern-list)
  170.                 ) )
  171.                 (:EXPORT
  172.                   (dolist (name (rest option))
  173.                     (push (check-symname name) export-list)
  174.                 ) )
  175.                 (T (error-of-type 'program-error
  176.                      (DEUTSCH "~S ~A: Die Option ~S gibt es nicht."
  177.                       ENGLISH "~S ~A: unknown option ~S"
  178.                       FRANCAIS "~S ~A : Option ~S non reconnue.")
  179.                      'defpackage packname (first option)
  180.               ) )  )
  181.               (error-of-type 'program-error
  182.                 (DEUTSCH "~S ~A: Falsche Syntax in ~S-Option: ~S"
  183.                  ENGLISH "~S ~A: invalid syntax in ~S option: ~S"
  184.                  FRANCAIS "~S ~A : Mauvaise syntaxe dans l'option ~S: ~S")
  185.                 'defpackage packname 'defpackage option
  186.             ) )
  187.             (error-of-type 'program-error
  188.               (DEUTSCH "~S ~A: Das ist keine ~S-Option: ~S"
  189.                ENGLISH "~S ~A: not a ~S option: ~S"
  190.                FRANCAIS "~S ~A : Ceci n'est pas une option ~S: ~S")
  191.               'defpackage packname 'defpackage option
  192.         ) ) )
  193.         ; Auf ▄berschneidungen zwischen intern-list und export-list prⁿfen:
  194.         (setq symname-list intern-list)
  195.         (mapc #'record-symname export-list)
  196.       )
  197.       ; Listen umdrehen und Default-Werte eintragen:
  198.       (setq nickname-list (nreverse nickname-list))
  199.       (setq shadow-list (nreverse shadow-list))
  200.       (setq shadowing-list (nreverse shadowing-list))
  201.       (setq use-list (or use-default (nreverse use-list)))
  202.       (setq import-list (nreverse import-list))
  203.       (setq intern-list (nreverse intern-list))
  204.       (setq export-list (nreverse export-list))
  205.       ; Expansion produzieren:
  206.       `(EVAL-WHEN (LOAD COMPILE EVAL)
  207.          (SYSTEM::%IN-PACKAGE ,packname :NICKNAMES ',nickname-list :USE '())
  208.          ; Schritt 1
  209.          ,@(if shadow-list
  210.              `((SHADOW ',(mapcar #'make-symbol shadow-list) ,packname))
  211.            )
  212.          ,@(mapcar
  213.              #'(lambda (pair)
  214.                  `(SHADOWING-IMPORT-CERROR ,(car pair) ,(cdr pair) ,packname)
  215.                )
  216.              shadowing-list
  217.            )
  218.          ; Schritt 2
  219.          ,@(if use-list `((USE-PACKAGE ',use-list ,packname)))
  220.          ; Schritt 3
  221.          ,@(mapcar
  222.              #'(lambda (pair)
  223.                  `(IMPORT-CERROR ,(car pair) ,(cdr pair) ,packname)
  224.                )
  225.              import-list
  226.            )
  227.          ,@(mapcar
  228.              #'(lambda (symname) `(INTERN ,symname ,packname))
  229.              intern-list
  230.            )
  231.          ; Schritt 4
  232.          ,@(if export-list
  233.              `((INTERN-EXPORT ',export-list ,packname))
  234.            )
  235.          (FIND-PACKAGE ,packname)
  236.        )
  237. ) ) )
  238. ; Hilfsfunktionen:
  239. (defun find-symbol-cerror (string packname calling-packname)
  240.   (multiple-value-bind (sym found) (find-symbol string packname)
  241.     (unless found
  242.       (cerror ; 'package-error ??
  243.               (DEUTSCH "Dieses Symbol wird erzeugt."
  244.                ENGLISH "This symbol will be created."
  245.                FRANCAIS "Ce symbole sera crΘΘ.")
  246.               (DEUTSCH "~S ~A: Es gibt kein Symbol ~A::~A ."
  247.                ENGLISH "~S ~A: There is no symbol ~A::~A ."
  248.                FRANCAIS "~S ~A : Il n'y a pas de symbole ~A::~A .")
  249.               'defpackage calling-packname packname string
  250.       )
  251.       (setq sym (intern string packname))
  252.     )
  253.     sym
  254. ) )
  255. (defun shadowing-import-cerror (string packname calling-packname)
  256.   (shadowing-import (find-symbol-cerror string packname calling-packname)
  257.                     calling-packname
  258. ) )
  259. (defun import-cerror (string packname calling-packname)
  260.   (import (find-symbol-cerror string packname calling-packname)
  261.           calling-packname
  262. ) )
  263. (defun intern-export (string-list packname)
  264.   (export (mapcar #'(lambda (string) (intern string packname)) string-list)
  265.           packname
  266. ) )
  267.  
  268. ;-------------------------------------------------------------------------------
  269.  
  270. ;; cf. X3J13 vote <173>
  271.  
  272. ;; Definition globaler Symbol-Macros
  273. (defmacro define-symbol-macro (symbol expansion)
  274.   (unless (symbolp symbol)
  275.     (error-of-type 'program-error
  276.       (DEUTSCH "~S: Der Name eines Symbol-Macros mu▀ ein Symbol sein, nicht: ~S"
  277.        ENGLISH "~S: the name of a symbol macro must be a symbol, not ~S"
  278.        FRANCAIS "~S : Le nom d'un macro symbole doit Ωtre un symbole et non ~S")
  279.       'define-symbol-macro symbol
  280.   ) )
  281.   `(LET ()
  282.      (EVAL-WHEN (COMPILE LOAD EVAL)
  283.        (CHECK-NOT-SPECIAL-VARIABLE-P ',symbol)
  284.        (MAKUNBOUND ',symbol)
  285.        (SET ',symbol (SYSTEM::MAKE-SYMBOL-MACRO ',expansion))
  286.      )
  287.      ',symbol
  288.    )
  289. )
  290.  
  291. (defun check-not-special-variable-p (symbol)
  292.   (when (special-variable-p symbol)
  293.     (error-of-type 'error
  294.       (DEUTSCH "~S: Das Symbol ~S benennt eine globale Variable."
  295.        ENGLISH "~S: the symbol ~S names a global variable"
  296.        FRANCAIS "~S : Le symbole ~S est le nom d'une variable globale.")
  297.       'define-symbol-macro symbol
  298. ) ) )
  299.  
  300. ;-------------------------------------------------------------------------------
  301.  
  302. ;; X3J13 vote <40>
  303.  
  304. (defmacro print-unreadable-object
  305.     ((&whole args object stream &key type identity) &body body)
  306.   (declare (ignore object stream type identity))
  307.   `(SYSTEM::WRITE-UNREADABLE
  308.      ,(if body `(FUNCTION (LAMBDA () ,@body)) 'NIL)
  309.      ,@args
  310.    )
  311. )
  312.  
  313. ;-------------------------------------------------------------------------------
  314.  
  315. ;; X3J13 vote <144>
  316.  
  317. (defmacro declaim (&rest decl-specs)
  318.   `(PROGN
  319.      ,@(mapcar #'(lambda (decl-spec) `(PROCLAIM (QUOTE ,decl-spec))) decl-specs)
  320.    )
  321. )
  322.  
  323. ;-------------------------------------------------------------------------------
  324.  
  325. ;; X3J13 vote <64>
  326.  
  327. (defmacro destructuring-bind (lambdalist form &body body &environment env)
  328.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  329.     (if declarations (setq declarations `((DECLARE ,@declarations))))
  330.     (let ((%arg-count 0) (%min-args 0) (%restp nil)
  331.           (%let-list nil) (%keyword-tests nil) (%default-form nil))
  332.       (analyze1 lambdalist '<DESTRUCTURING-FORM> 'destructuring-bind '<DESTRUCTURING-FORM>)
  333.       (let ((lengthtest (make-length-test '<DESTRUCTURING-FORM> 0))
  334.             (mainform `(LET* ,(nreverse %let-list)
  335.                          ,@declarations
  336.                          ,@(nreverse %keyword-tests)
  337.                          ,@body-rest
  338.            ))          )
  339.         (if lengthtest
  340.           (setq mainform
  341.             `(IF ,lengthtest
  342.                (DESTRUCTURING-ERROR <DESTRUCTURING-FORM>
  343.                                     '(,%min-args . ,(if %restp nil %arg-count))
  344.                )
  345.                ,mainform
  346.         ) )  )
  347.         `(LET ((<DESTRUCTURING-FORM> ,form)) ,mainform)
  348. ) ) ) )
  349.  
  350. (defun destructuring-error (destructuring-form min.max)
  351.   (let ((min (car min.max))
  352.         (max (cdr min.max)))
  353.     (error-of-type 'error
  354.       (DEUTSCH "Das zu zerlegende Objekt sollte eine Liste mit ~:[mindestens ~*~S~;~:[~S bis ~S~;~S~]~] Elementen sein, nicht ~4@*~S."
  355.        ENGLISH "The object to be destructured should be a list with ~:[at least ~*~S~;~:[from ~S to ~S~;~S~]~] elements, not ~4@*~S."
  356.        FRANCAIS "L'objet α dΘmonter devrait Ωtre une liste ~:[d'au moins ~*~S~;de ~:[~S α ~S~;~S~]~] ΘlΘments et non ~4@*~S.")
  357.       max (eql min max) min max destructuring-form
  358. ) ) )
  359.  
  360. ;-------------------------------------------------------------------------------
  361.  
  362. ;; X3J13 vote <87>
  363.  
  364. (defun complement (fun)
  365.   #'(lambda (&rest arguments) (not (apply fun arguments)))
  366. )
  367.  
  368. ;; dpANS
  369.  
  370. (defun constantly (object)
  371.   #'(lambda (&rest arguments) (declare (ignore arguments)) object)
  372. )
  373.  
  374. ;-------------------------------------------------------------------------------
  375.  
  376. ;; part of X3J13 vote <40>
  377.  
  378. (defconstant *common-lisp-user-package* (find-package "COMMON-LISP-USER"))
  379.  
  380. (defmacro with-standard-io-syntax (&body body &environment env)
  381.   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  382.     ; It would be possible to put all these bindings into a single function,
  383.     ; but this would force variables into closures.
  384.     `(LET (; printer/reader variables:
  385.            (*PACKAGE*                   *COMMON-LISP-USER-PACKAGE*)
  386.            ; printer variables:
  387.            (*PRINT-ARRAY*               T)
  388.            (*PRINT-BASE*                10)
  389.            (*PRINT-CASE*                ':UPCASE)
  390.            (*PRINT-CIRCLE*              NIL)
  391.            (*PRINT-ESCAPE*              T)
  392.            (*PRINT-GENSYM*              T)
  393.            (*PRINT-LENGTH*              NIL)
  394.            (*PRINT-LEVEL*               NIL)
  395.           ;(*PRINT-LINES*               NIL) ; XP variable not present in CLISP
  396.           ;(*PRINT-MISER-WIDTH*         NIL) ; XP variable not present in CLISP
  397.           ;(*PRINT-PPRINT-DISPATCH*     NIL) ; XP variable not present in CLISP
  398.            (*PRINT-PRETTY*              NIL)
  399.            (*PRINT-RADIX*               NIL)
  400.            (*PRINT-READABLY*            T)
  401.           ;(*PRINT-RIGHT-MARGIN*        NIL) ; XP variable not present in CLISP
  402.            (*PRINT-CLOSURE*             NIL) ; CLISP specific
  403.            (*PRINT-RPARS*               T) ; CLISP specific
  404.            (*PRINT-INDENT-LISTS*        2) ; CLISP specific
  405.            (SYSTEM::*PRIN-STREAM*       NIL) ; CLISP specific
  406.            (SYSTEM::*PRIN-LINELENGTH*   79) ; CLISP specific
  407.            ; reader variables:
  408.            (*READ-BASE*                 10)
  409.            (*READ-DEFAULT-FLOAT-FORMAT* 'SINGLE-FLOAT)
  410.           ;(*READ-EVAL*                 T) ; *READ-EVAL* not present in CLISP
  411.            (*READ-SUPPRESS*             NIL)
  412.            (*READTABLE*                 (COPY-READTABLE NIL))
  413.           )
  414.        ,@(if declarations `((DECLARE ,@declarations)))
  415.        ,@body-rest
  416.      )
  417. ) )
  418.  
  419. ;-------------------------------------------------------------------------------
  420.  
  421. ;; part of X3J13 vote <98>
  422.  
  423. (defmacro with-hash-table-iterator ((macroname hashtable) &body body)
  424.   (unless (symbolp macroname)
  425.     (error (DEUTSCH "~S: Macroname mu▀ ein Symbol sein, nicht ~S"
  426.             ENGLISH "~S: macro name should be a symbol, not ~S"
  427.             FRANCAIS "~S : le nom de macro n'est pas un symbole: ~S")
  428.            'with-hash-table-iterator macroname
  429.   ) )
  430.   (let ((var (gensym)))
  431.     `(LET ((,var (SYS::HASH-TABLE-ITERATOR ,hashtable)))
  432.        (MACROLET ((,macroname () '(SYS::HASH-TABLE-ITERATE ,var) ))
  433.          ,@body
  434.      ) )
  435. ) )
  436.  
  437. ;-------------------------------------------------------------------------------
  438.  
  439. ;; dpANS
  440.  
  441. (defmacro lambda (&whole whole
  442.                   lambdalist &body body)
  443.   (declare (ignore lambdalist body))
  444.   `(FUNCTION ,whole)
  445. )
  446.  
  447. ;-------------------------------------------------------------------------------
  448.  
  449.