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