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