home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / cmpnew / cmputil.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-03  |  6.2 KB  |  208 lines
  1. ;;; CMPUTIL  Miscellaneous Functions.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (export '(*suppress-compiler-warnings*
  10.           *suppress-compiler-notes*
  11.           *compiler-break-enable*))
  12.  
  13. (defmacro safe-compile (&rest forms) `(when *safe-compile* ,@forms))
  14.  
  15. (defvar *current-form* '|compiler preprocess|)
  16. (defvar *first-error* t)
  17. (defvar *error-count* 0)
  18.  
  19. (defconstant *cmperr-tag* (cons nil nil))
  20.  
  21. (defun cmperr (string &rest args &aux (*print-case* :upcase))
  22.   (print-current-form)
  23.   (format t "~&;;; ")
  24.   (apply #'format t string args)
  25.   (incf *error-count*)
  26.   (throw *cmperr-tag* '*cmperr-tag*))
  27.  
  28. (defmacro cmpck (condition string &rest args)
  29.   `(if ,condition (cmperr ,string ,@args)))
  30.  
  31. (defun too-many-args (name upper-bound n &aux (*print-case* :upcase))
  32.   (print-current-form)
  33.   (format t
  34.           ";;; ~S requires at most ~R argument~:p, ~
  35.           but ~R ~:*~[were~;was~:;were~] supplied.~%"
  36.           name
  37.           upper-bound
  38.           n)
  39.   (incf *error-count*)
  40.   (throw *cmperr-tag* '*cmperr-tag*))
  41.  
  42. (defun too-few-args (name lower-bound n &aux (*print-case* :upcase))
  43.   (print-current-form)
  44.   (format t
  45.           ";;; ~S requires at least ~R argument~:p, ~
  46.           but only ~R ~:*~[were~;was~:;were~] supplied.~%"
  47.           name
  48.           lower-bound
  49.           n)
  50.   (incf *error-count*)
  51.   (throw *cmperr-tag* '*cmperr-tag*))
  52.  
  53. (defvar *suppress-compiler-warnings* nil)
  54.  
  55. (defun cmpwarn (string &rest args &aux (*print-case* :upcase))
  56.   (unless *suppress-compiler-warnings*
  57.     (print-current-form)
  58.     (format t ";; Warning: ")
  59.     (apply #'format t string args)
  60.     (terpri))
  61.   nil)
  62.  
  63. (defvar *suppress-compiler-notes* nil)
  64.  
  65. (defun cmpnote (string &rest args &aux (*print-case* :upcase))
  66.   (unless *suppress-compiler-notes* 
  67.     (terpri)
  68.     (format t ";; Note: ")
  69.     (apply #'format t string args))
  70.   nil)
  71.  
  72. (defun print-current-form ()
  73.   (when *first-error*
  74.         (setq *first-error* nil)
  75.         (fresh-line)
  76.         (cond
  77.          ((and (consp *current-form*)
  78.                (eq (car *current-form*) 'si:|#,|))
  79.           (format t "; #,~s is being compiled.~%" (cdr *current-form*)))
  80.          (t
  81.           (let ((*print-length* 2)
  82.                 (*print-level* 2))
  83.                (format t "; ~s is being compiled.~%" *current-form*)))))
  84.   nil)
  85.  
  86. (defun undefined-variable (sym &aux (*print-case* :upcase))
  87.   (print-current-form)
  88.   (format t
  89.           ";; The variable ~s is undefined.~%~
  90.            ;; The compiler will assume this variable is a global.~%"
  91.           sym)
  92.   nil)
  93.  
  94. (defun baboon (&aux (*print-case* :upcase))
  95.   (print-current-form)
  96.   (format t ";;; A bug was found in the compiler.  Contact Taiichi.~%")
  97.   (incf *error-count*)
  98.   (break)
  99. ;  (throw *cmperr-tag* '*cmperr-tag*)
  100. )
  101.  
  102. ;;; Internal Macros with type declarations
  103.  
  104. (defmacro dolist* ((v l &optional (val nil)) . body)
  105.   (let ((temp (gensym)))
  106.   `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp)))
  107.     ((endp ,temp) ,val)
  108.     (declare (object ,v))
  109.     ,@body)))
  110.  
  111. (defmacro dolist** ((v l &optional (val nil)) . body)
  112.   (let ((temp (gensym)))
  113.   `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp)))
  114.     ((endp ,temp) ,val)
  115.     (declare (object ,temp ,v))
  116.     ,@body)))
  117.  
  118. (defmacro dotimes* ((v n &optional (val nil)) . body)
  119.   (let ((temp (gensym)))
  120.    `(do* ((,temp ,n) (,v 0 (1+ ,v)))
  121.      ((>= ,v ,temp) ,val)
  122.      (declare (fixnum ,v))
  123.      ,@body)))
  124.  
  125. (defmacro dotimes** ((v n &optional (val nil)) . body)
  126.   (let ((temp (gensym)))
  127.    `(do* ((,temp ,n) (,v 0 (1+ ,v)))
  128.      ((>= ,v ,temp) ,val)
  129.      (declare (fixnum ,temp ,v))
  130.      ,@body)))
  131.  
  132. (defun cmp-eval (form)
  133.   (let ((x (multiple-value-list (cmp-toplevel-eval `(eval ',form)))))
  134.     (if (car x)
  135.         (let ((*print-case* :upcase))
  136.           (incf *error-count*)
  137.           (print-current-form)
  138.           (format t
  139.                   ";;; The form ~s was not evaluated successfully.~%~
  140.                   ;;; You are recommended to compile again.~%"
  141.                   form)
  142.           nil)
  143.         (values-list (cdr x)))))
  144.  
  145. (defun cmp-macroexpand (form)
  146.   (let ((x (multiple-value-list (cmp-toplevel-eval `(macroexpand ',form)))))
  147.     (if (car x)
  148.         (let ((*print-case* :upcase))
  149.           (incf *error-count*)
  150.           (print-current-form)
  151.           (format t
  152.                   ";;; The macro form ~s was not expanded successfully.~%"
  153.                   form)
  154.           `(error "Macro-expansion of ~s failed at compile time." ',form))
  155.         (cadr x))))
  156.  
  157. (defun cmp-macroexpand-1 (form)
  158.   (let ((x (multiple-value-list (cmp-toplevel-eval `(macroexpand-1 ',form)))))
  159.     (if (car x)
  160.         (let ((*print-case* :upcase))
  161.           (incf *error-count*)
  162.           (print-current-form)
  163.           (format t
  164.                   ";;; The macro form ~s was not expanded successfully.~%"
  165.                   form)
  166.           `(error "Macro-expansion of ~s failed at compile time." ',form))
  167.         (cadr x))))
  168.  
  169. (defun cmp-expand-macro (fd fname args)
  170.   (let ((x (multiple-value-list
  171.             (cmp-toplevel-eval
  172.              `(funcall *macroexpand-hook* ',fd ',(cons fname args) nil)))))
  173.     (if (car x)
  174.         (let ((*print-case* :upcase))
  175.           (incf *error-count*)
  176.           (print-current-form)
  177.           (format t
  178.             ";;; The macro form (~s ...) was not expanded successfully.~%"
  179.             fname)
  180.           `(error "Macro-expansion of ~s failed at compile time."
  181.                   ',(cons fname args)))
  182.         (cadr x))))
  183.  
  184. (defvar *compiler-break-enable* nil)
  185.  
  186. (defun cmp-toplevel-eval (form)
  187.    (let* ((si::*ihs-base* si::*ihs-top*)
  188.           (si::*ihs-top* (1- (si::ihs-top)))
  189.           (*break-enable* *compiler-break-enable*)
  190.           (si::*break-hidden-packages*
  191.            (cons (find-package 'compiler)
  192.                  si::*break-hidden-packages*)))
  193.          (si:error-set form)))
  194.  
  195. (defun compiler-clear-compiler-properties (symbol)
  196.   (remprop symbol 'package-operation)
  197.   (remprop symbol 't1)
  198.   (remprop symbol 't2)
  199.   (remprop symbol 't3)
  200.   (remprop symbol 'top-level-macro)
  201.   (remprop symbol 'c1)
  202.   (remprop symbol 'c2)
  203.   (remprop symbol 'c1conditional)
  204.   (remprop symbol 'inline-always)
  205.   (remprop symbol 'inline-unsafe)
  206.   (remprop symbol 'inline-safe)
  207.   (remprop symbol 'lfun))
  208.