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 / macros2.lsp < prev    next >
Encoding:
Text File  |  1996-06-15  |  15.0 KB  |  373 lines
  1. (in-package "SYSTEM")
  2. ;-------------------------------------------------------------------------------
  3. (defmacro typecase (keyform &rest typeclauselist)
  4.   (let* ((tempvar (gensym))
  5.          (condclauselist nil))
  6.     (do ((typeclauselistr typeclauselist (cdr typeclauselistr)))
  7.         ((atom typeclauselistr))
  8.       (cond ((atom (car typeclauselistr))
  9.              (error-of-type 'program-error
  10.                (DEUTSCH "UnzulΣssige Klausel in ~S: ~S"
  11.                 ENGLISH "Invalid clause in ~S: ~S"
  12.                 FRANCAIS "Clause inadmissible dans ~S : ~S")
  13.                'typecase (car typeclauselistr)
  14.             ))
  15.             ((let ((type (caar typeclauselistr)))
  16.                (or (eq type T) (eq type 'OTHERWISE))
  17.              )
  18.              (push `(T ,@(or (cdar typeclauselistr) '(NIL))) condclauselist)
  19.              (return)
  20.             )
  21.             (t (push `((TYPEP ,tempvar (QUOTE ,(caar typeclauselistr)))
  22.                        ,@(or (cdar typeclauselistr) '(NIL))
  23.                       )
  24.                      condclauselist
  25.             )  )
  26.     ) )
  27.     `(LET ((,tempvar ,keyform)) (COND ,@(nreverse condclauselist)))
  28. ) )
  29. ;-------------------------------------------------------------------------------
  30. (defmacro check-type (place typespec &optional (string nil))
  31.   (let ((tag1 (gensym))
  32.         (tag2 (gensym)))
  33.     `(TAGBODY
  34.        ,tag1
  35.        (WHEN (TYPEP ,place ',typespec) (GO ,tag2))
  36.        (CERROR (DEUTSCH "Sie dⁿrfen einen neuen Wert eingeben."
  37.                 ENGLISH "You may input a new value."
  38.                 FRANCAIS "Vous avez l'occasion d'entrer une nouvelle valeur.")
  39.          (DEUTSCH "~A~%Der Wert ist: ~S"
  40.           ENGLISH "~A~%The value is: ~S"
  41.           FRANCAIS "~A~%La valeur est : ~S")
  42.          (DEUTSCH ,(format nil "Der Wert von ~S sollte ~:[vom Typ ~S~;~:*~A~] sein."
  43.                                place string typespec
  44.                    )
  45.           ENGLISH ,(format nil "The value of ~S should be ~:[of type ~S~;~:*~A~]."
  46.                                place string typespec
  47.                    )
  48.           FRANCAIS ,(format nil "La valeur de ~S devrait Ωtre ~:[de type ~S~;~:*~A~]."
  49.                                 place string typespec
  50.                     )
  51.          )
  52.          ,place
  53.        )
  54.        (WRITE-STRING
  55.          (DEUTSCH ,(format nil "~%Neues ~S: " place)
  56.           ENGLISH ,(format nil "~%New ~S: " place)
  57.           FRANCAIS ,(format nil "~%Nouveau ~S : " place)
  58.          )
  59.          *QUERY-IO*
  60.        )
  61.        (SETF ,place (READ *QUERY-IO*))
  62.        (GO ,tag1)
  63.        ,tag2
  64.      )
  65. ) )
  66. ;-------------------------------------------------------------------------------
  67. (defmacro assert (test-form &optional (place-list nil) (string nil) &rest args)
  68.   (let ((tag1 (gensym))
  69.         (tag2 (gensym)))
  70.     `(TAGBODY
  71.        ,tag1
  72.        (WHEN ,test-form (GO ,tag2))
  73.        (CERROR ,(case (length place-list)
  74.                   (0 `(DEUTSCH "Neuer Anlauf"
  75.                        ENGLISH "Retry"
  76.                        FRANCAIS "ReΘssayer")
  77.                   )
  78.                   (1 `(DEUTSCH "Sie dⁿrfen einen neuen Wert eingeben."
  79.                        ENGLISH "You may input a new value."
  80.                        FRANCAIS "Vous pouvez entrer une nouvelle valeur.")
  81.                   )
  82.                   (t `(DEUTSCH "Sie dⁿrfen neue Werte eingeben."
  83.                        ENGLISH "You may input new values."
  84.                        FRANCAIS "Vous pouvez entrer de nouvelles valeurs.")
  85.                 ) )
  86.                ',(or string "~A")
  87.                ,@(if string
  88.                    args
  89.                    (list `(DEUTSCH ,(format nil "Der Wert von ~S darf nicht NIL sein." test-form)
  90.                            ENGLISH ,(format nil "~S must evaluate to a non-NIL value." test-form)
  91.                            FRANCAIS ,(format nil "La valeur de ~S ne peut pas Ωtre NIL." test-form))
  92.                  ) )
  93.        )
  94.        ,@(mapcan
  95.            #'(lambda (place)
  96.                (list `(WRITE-STRING
  97.                         (DEUTSCH ,(format nil "~%Neues ~S: " place)
  98.                          ENGLISH ,(format nil "~%New ~S: " place)
  99.                          FRANCAIS ,(format nil "~%Nouveau ~S : " place)
  100.                         )
  101.                         *QUERY-IO*
  102.                       )
  103.                      `(SETF ,place (READ *QUERY-IO*))
  104.              ) )
  105.            place-list
  106.          )
  107.        (GO ,tag1)
  108.        ,tag2
  109.      )
  110. ) )
  111. ;-------------------------------------------------------------------------------
  112. (flet ((typecase-errorstring (keyform keyclauselist)
  113.          (let ((typelist (mapcar #'first keyclauselist)))
  114.            `(DEUTSCH ,(format nil "Der Wert von ~S mu▀ einem der Typen ~{~S~^, ~} angeh÷ren." keyform typelist)
  115.              ENGLISH ,(format nil "The value of ~S must be of one of the types ~{~S~^, ~}" keyform typelist)
  116.              FRANCAIS ,(format nil "La valeur de ~S doit appartenir α l'un des types ~{~S~^, ~}." keyform typelist)
  117.             )
  118.        ) )
  119.        (typecase-expected-type (keyclauselist)
  120.          `(OR ,@(mapcar #'first keyclauselist))
  121.        )
  122.        (case-errorstring (keyform keyclauselist)
  123.          (let ((caselist
  124.                  (mapcap #'(lambda (keyclause)
  125.                              (setq keyclause (car keyclause))
  126.                              (if (listp keyclause) keyclause (list keyclause))
  127.                            )
  128.                          keyclauselist
  129.               )) )
  130.            `(DEUTSCH ,(format nil "Der Wert von ~S mu▀ einer der folgenden sein: ~{~S~^, ~}" keyform caselist)
  131.              ENGLISH ,(format nil "The value of ~S must be one of ~{~S~^, ~}" keyform caselist)
  132.              FRANCAIS ,(format nil "La valeur de ~S doit Ωtre l'une des suivantes : ~{~S~^, ~}" keyform caselist)
  133.             )
  134.        ) )
  135.        (case-expected-type (keyclauselist)
  136.          `(MEMBER ,@(mapcap #'(lambda (keyclause)
  137.                                 (setq keyclause (car keyclause))
  138.                                 (if (listp keyclause) keyclause (list keyclause))
  139.                               )
  140.                             keyclauselist
  141.           )         )
  142.        )
  143.        (simply-error (casename form clauselist errorstring expected-type)
  144.          (let ((var (gensym)))
  145.            `(LET ((,var ,form))
  146.               (,casename ,var
  147.                 ,@clauselist
  148.                 (OTHERWISE
  149.                   (ERROR-OF-TYPE 'TYPE-ERROR
  150.                     :DATUM ,var :EXPECTED-TYPE ',expected-type
  151.                     (DEUTSCH "~A~%Der Wert ist: ~S"
  152.                      ENGLISH "~A~%The value is: ~S"
  153.                      FRANCAIS "~A~%La valeur est : ~S")
  154.                     ,errorstring ,var
  155.             ) ) ) )
  156.        ) )
  157.        (retry-loop (casename place clauselist errorstring)
  158.          (let ((g (gensym))
  159.                (h (gensym)))
  160.            `(BLOCK ,g
  161.               (TAGBODY
  162.                 ,h
  163.                 (RETURN-FROM ,g
  164.                   (,casename ,place
  165.                     ,@clauselist
  166.                     (OTHERWISE
  167.                       (CERROR (DEUTSCH "Sie dⁿrfen einen neuen Wert eingeben."
  168.                                ENGLISH "You may input a new value."
  169.                                FRANCAIS "Vous pouvez entrer une nouvelle valeur.")
  170.                               (DEUTSCH "~A~%Der Wert ist: ~S"
  171.                                ENGLISH "~A~%The value is: ~S"
  172.                                FRANCAIS "~A~%La valeur est : ~S")
  173.                               ,errorstring
  174.                               ,place
  175.                       )
  176.                       (WRITE-STRING
  177.                         (DEUTSCH ,(format nil "~%Neues ~S: " place)
  178.                          ENGLISH ,(format nil "~%New ~S: " place)
  179.                          FRANCAIS,(format nil "~%Nouveau ~S : " place)
  180.                         )
  181.                         *QUERY-IO*
  182.                       )
  183.                       (SETF ,place (READ *QUERY-IO*))
  184.                       (GO ,h)
  185.             ) ) ) ) )
  186.       )) )
  187.   (defmacro etypecase (keyform &rest keyclauselist)
  188.     (simply-error 'TYPECASE keyform keyclauselist
  189.                   (typecase-errorstring keyform keyclauselist)
  190.                   (typecase-expected-type keyclauselist)
  191.   ) )
  192.   (defmacro ctypecase (keyplace &rest keyclauselist)
  193.     (retry-loop 'TYPECASE keyplace keyclauselist
  194.                 (typecase-errorstring keyplace keyclauselist)
  195.   ) )
  196.   (defmacro ecase (keyform &rest keyclauselist)
  197.     (simply-error 'CASE keyform keyclauselist
  198.                   (case-errorstring keyform keyclauselist)
  199.                   (case-expected-type keyclauselist)
  200.   ) )
  201.   (defmacro ccase (keyform &rest keyclauselist)
  202.     (retry-loop 'CASE keyform keyclauselist
  203.                 (case-errorstring keyform keyclauselist)
  204.   ) )
  205. )
  206. ;-------------------------------------------------------------------------------
  207. (defmacro deftype (name lambdalist &body body &environment env)
  208.   (unless (symbolp name)
  209.     (error-of-type 'program-error
  210.       (DEUTSCH "Typname mu▀ ein Symbol sein, nicht ~S"
  211.        ENGLISH "type name should be a symbol, not ~S"
  212.        FRANCAIS "Le type doit Ωtre un symbole et non ~S")
  213.       name
  214.   ) )
  215.   (if (or (get name 'TYPE-SYMBOL) (get name 'TYPE-LIST))
  216.     (error-of-type 'program-error
  217.       (DEUTSCH "~S ist ein eingebauter Typ und darf nicht umdefiniert werden."
  218.        ENGLISH "~S is a built-in type and may not be redefined."
  219.        FRANCAIS "~S est un type prΘdΘfini et ne peut pas Ωtre redΘfini.")
  220.       name
  221.   ) )
  222.   (multiple-value-bind (body-rest declarations docstring)
  223.       (SYSTEM::PARSE-BODY body t env)
  224.     (if declarations (setq declarations (list (cons 'DECLARE declarations))))
  225.     (let ((%arg-count 0) (%min-args 0) (%restp nil)
  226.           (%let-list nil) (%keyword-tests nil) (%default-form '(QUOTE *)))
  227.       (analyze1 lambdalist '(CDR <DEFTYPE-FORM>) name '<DEFTYPE-FORM>)
  228.       (let ((lengthtest (make-length-test '<DEFTYPE-FORM>))
  229.             (mainform `(LET* ,(nreverse %let-list)
  230.                          ,@declarations
  231.                          ,@(nreverse %keyword-tests)
  232.                          ,@body-rest
  233.            ))          )
  234.         (if lengthtest
  235.           (setq mainform
  236.             `(IF ,lengthtest
  237.                (TYPE-CALL-ERROR <DEFTYPE-FORM>)
  238.                ,mainform
  239.         ) )  )
  240.         `(EVAL-WHEN (COMPILE LOAD EVAL)
  241.            (LET ()
  242.              (%PUT ',name 'DEFTYPE-EXPANDER
  243.                (FUNCTION ,(make-symbol (string-concat "DEFTYPE-" (string name)))
  244.                  (LAMBDA (<DEFTYPE-FORM>) (BLOCK ,name ,mainform))
  245.              ) )
  246.              (SETF (DOCUMENTATION ',name 'TYPE) ',docstring)
  247.              ',name
  248.          ) )
  249. ) ) ) )
  250. (defun type-call-error (deftype-form)
  251.   (error-of-type 'error
  252.     (DEUTSCH "Der Deftype-Expander fⁿr ~S kann nicht mit ~S Argumenten aufgerufen werden."
  253.      ENGLISH "The deftype expander for ~S may not be called with ~S arguments."
  254.      FRANCAIS "L'½expandeur╗ de DEFTYPE pour ~S ne peut pas Ωtre appelΘ avec ~S arguments.")
  255.     (car deftype-form) (1- (length deftype-form))
  256. ) )
  257. ;-------------------------------------------------------------------------------
  258. (defmacro time (form)
  259.   (let ((vars (list (gensym) (gensym) (gensym) (gensym) (gensym) (gensym)
  260.                     (gensym) (gensym) (gensym)
  261.        ))     )
  262.     `(MULTIPLE-VALUE-BIND ,vars (%%TIME)
  263.        (UNWIND-PROTECT ,form (MULTIPLE-VALUE-CALL #'%TIME (%%TIME) ,@vars))
  264.      ) ; Diese Konstruktion verbraucht zur Laufzeit nur Stackplatz!
  265. ) )
  266. ;-------------------------------------------------------------------------------
  267. (defmacro with-input-from-string
  268.     ((var string &key (index nil sindex) (start '0 sstart) (end 'NIL send))
  269.      &body body &environment env)
  270.   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  271.     (if declarations
  272.       (setq declarations (list (cons 'DECLARE declarations)))
  273.     )
  274.     `(LET ((,var (MAKE-STRING-INPUT-STREAM ,string
  275.                    ,@(if (or sstart send)
  276.                        `(,start ,@(if send `(,end) '()))
  277.                        '()
  278.           ))     )   )
  279.        ,@declarations
  280.        (UNWIND-PROTECT
  281.          (PROGN ,@body-rest)
  282.          ,@(if sindex `((SETF ,index (SYSTEM::STRING-INPUT-STREAM-INDEX ,var))) '())
  283.          (CLOSE ,var)
  284.      ) )
  285. ) )
  286. ;-------------------------------------------------------------------------------
  287. (defmacro with-open-file ((stream &rest options) &body body &environment env)
  288.   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  289.     (if declarations
  290.       (setq declarations (list (cons 'DECLARE declarations)))
  291.     )
  292.     `(LET ((,stream (OPEN ,@options)))
  293.        ,@declarations
  294.        (UNWIND-PROTECT
  295.          (MULTIPLE-VALUE-PROG1 (PROGN ,@body-rest)
  296.            (WHEN ,stream (CLOSE ,stream))
  297.          )
  298.          (WHEN ,stream (CLOSE ,stream :ABORT T))
  299.      ) )
  300. ) )
  301. ;-------------------------------------------------------------------------------
  302. (defmacro with-open-stream ((var stream) &body body &environment env)
  303.   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  304.     (if declarations
  305.       (setq declarations (list (cons 'DECLARE declarations)))
  306.     )
  307.     `(LET ((,var ,stream))
  308.        ,@declarations
  309.        (UNWIND-PROTECT
  310.          (MULTIPLE-VALUE-PROG1 (PROGN ,@body-rest) (CLOSE ,var))
  311.          (CLOSE ,var :ABORT T)
  312.      ) )
  313. ) )
  314. ;-------------------------------------------------------------------------------
  315. (defmacro with-output-to-string
  316.     ((var &optional (string nil sstring)) &body body &environment env)
  317.   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  318.     (if declarations
  319.       (setq declarations (list (cons 'DECLARE declarations)))
  320.     )
  321.     (if sstring
  322.       `(LET ((,var (SYS::MAKE-STRING-PUSH-STREAM ,string)))
  323.          ,@declarations
  324.          (UNWIND-PROTECT
  325.            (PROGN ,@body-rest)
  326.            (CLOSE ,var)
  327.        ) )
  328.       `(LET ((,var (MAKE-STRING-OUTPUT-STREAM)))
  329.          ,@declarations
  330.          (UNWIND-PROTECT
  331.            (PROGN ,@body-rest (GET-OUTPUT-STREAM-STRING ,var))
  332.            (CLOSE ,var)
  333.        ) )
  334. ) ) )
  335. ;-------------------------------------------------------------------------------
  336. (in-package "LISP")
  337. (export 'with-output-to-printer)
  338. (in-package "SYSTEM")
  339. (defmacro with-output-to-printer ((var) &body body &environment env)
  340.   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  341.     (if declarations
  342.       (setq declarations (list (cons 'DECLARE declarations)))
  343.     )
  344.     `(LET ((,var (SYS::MAKE-PRINTER-STREAM)))
  345.        ,@declarations
  346.        (UNWIND-PROTECT
  347.          (PROGN ,@body-rest)
  348.          (CLOSE ,var)
  349.      ) )
  350. ) )
  351. #+UNIX
  352. (defun make-printer-stream () (make-pipe-output-stream "lpr"))
  353. #+(or DOS OS/2)
  354. (defun make-printer-stream () (open "prn" :direction :output))
  355. ;-------------------------------------------------------------------------------
  356. (in-package "LISP")
  357. (export 'without-floating-point-underflow)
  358. (in-package "SYSTEM")
  359. (defmacro without-floating-point-underflow (&body body)
  360.   `(LET ((SYS::*INHIBIT-FLOATING-POINT-UNDERFLOW* T))
  361.      (PROGN ,@body)
  362.    )
  363. )
  364. ;-------------------------------------------------------------------------------
  365. (in-package "LISP")
  366. (export 'language-case)
  367. (in-package "SYSTEM")
  368. (defmacro language-case (&body body)
  369.   `(CASE (DEUTSCH 'DEUTSCH ENGLISH 'ENGLISH FRANCAIS 'FRANCAIS) ,@body)
  370. )
  371. ;-------------------------------------------------------------------------------
  372.  
  373.