;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- ;;;; ;;;; CMPUTIL -- Miscellaneous Functions. ;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. ;;;; Copyright (c) 1990, Giuseppe Attardi. ;;;; Copyright (c) 2010-2017, Jean-Claude Beaudoin. ;;;; ;;;; ECoLisp is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. ;;;; ;;;; See file '../../Copyright' for full details. (in-package "COMPILER") (define-condition compiler-message (simple-condition) ((prefix :initform "Note" :accessor compiler-message-prefix) (file :initarg :file :initform *compile-file-pathname* :accessor compiler-message-file) (end-position :initarg :end-position :initform *compile-file-end-position* :accessor compiler-message-file-end-position) (form :initarg :form :initform *original-current-form* :accessor compiler-message-form)) (:REPORT (lambda (c stream) (let ((position (compiler-message-file-end-position c))) (if (< 0 position) (let ((*print-length* 3) (*print-level* 2) ) (format stream "~A: in file ~A, end position ~D,~% and form: ~A~%" (compiler-message-prefix c) (compiler-message-file c) position (compiler-message-form c))) (format stream "~A: " (compiler-message-prefix c))) (format stream " ~?" (simple-condition-format-control c) (simple-condition-format-arguments c)))))) (define-condition compiler-note (compiler-message) ()) (define-condition compiler-warning (compiler-message warning) ((prefix :initform "Warning"))) (define-condition compiler-style-warning (compiler-message style-warning) ((prefix :initform "Style Warning"))) (define-condition compiler-error (compiler-message error) ((prefix :initform "Error"))) (define-condition compiler-fatal-error (compiler-error) ()) (define-condition compiler-internal-error (compiler-fatal-error) ((prefix :initform "Internal error"))) (define-condition compiler-undefined-variable (compiler-style-warning) ((prefix :initform "Style Warning") (variable :initarg :name :initform nil)) (:report (lambda (condition stream) (let ((position (compiler-message-file-end-position condition))) (if (< 0 position) (let ((*print-length* 3) (*print-level* 2) ) (format stream "~A: in file ~A, end position ~D,~% and form: ~A~%" (compiler-message-prefix condition) (compiler-message-file condition) position (compiler-message-form condition))) (format stream "~A: " (compiler-message-prefix condition))) (format stream "Variable ~A was undefined. Compiler assumes it is a global." (slot-value condition 'variable)))))) (defun print-compiler-message (c stream) (unless (typep c *suppress-compiler-messages*) (format stream "~&~@<;;; ~@;~A~:>" c) ;;(format stream "~&;;; ~A" c) ;;(print ";;; " stream) (princ c stream) )) (defun handle-note (c) (declare (ignore c)) nil) (defun handle-warning/error (c) (push c *compiler-conditions*) nil) (defun handle-internal-error (c) (push c *compiler-conditions*) (invoke-debugger c) ;; give *debugger-hook* a chance to handle this (unless (typep c 'compiler-error) (signal 'compiler-internal-error :format-control "~A" :format-arguments (list c)) (print-compiler-message c t) (abort))) (defun do-compilation-unit (closure &key override) (cond (override (let* ((*active-protection* nil)) (do-compilation-unit closure))) ((null *active-protection*) (let* ((*active-protection* t) (*pending-actions* nil)) (unwind-protect (do-compilation-unit closure) (loop for action in *pending-actions* do (funcall action))))) (t (funcall closure)))) (eval-when (:compile-toplevel :load-toplevel :execute) (si::reopen-package :cl)) (defmacro cl:with-compilation-unit ((&rest options) &body body) `(si:without-fpe *compiler-floating-point-exclusion-set* (do-compilation-unit #'(lambda () ,@body) ,@options))) (eval-when (:compile-toplevel :load-toplevel :execute) (si::close-package :cl)) (defun compiler-debugger (outer-hook condition old-hook) (declare (ignore old-hook)) (when *compiler-break-enable* (when outer-hook (funcall outer-hook condition outer-hook)) (si::default-debugger condition)) (cmperr "~A" condition) ;; Wrap condition in a compiler-error to give it source context. (abort)) (defmacro with-compiler-env ((compiler-conditions) &body body) `(let ((*compiler-conditions* nil)) (declare (special *compiler-conditions*)) (restart-case (handler-bind (((and error (not compiler-message)) #'handle-internal-error)) (handler-bind ((compiler-note #'handle-note) (warning #'handle-warning/error) (compiler-error #'handle-warning/error) ((and compiler-message (not (or compiler-note warning compiler-error))) #'handle-note) ;; not really expected... ) (mt:with-lock (mt::+load-compile-lock+) (let ,+init-env-form+ (with-compilation-unit () ,@body))))) (abort (&optional c) :report "Abort compilation." (push (if c c :aborted) *compiler-conditions*) (format t "~&;;; Compilation failed!~%"))) (setf ,compiler-conditions *compiler-conditions*))) (defvar *c1form-level* 0) (defun print-c1forms (form) (cond ((consp form) (let ((*c1form-level* (1+ *c1form-level*))) (mapc #'print-c1forms form))) ((c1form-p form) (format t "~% ~D > ~A, parent ~A" *c1form-level* form (c1form-parent form)) (print-c1forms (c1form-args form)) form ))) (defun print-ref (ref-object stream) (let ((name (ref-name ref-object))) (if name (format stream "#" (type-of ref-object) name) (format stream "#" (type-of ref-object))))) (defun print-var (var-object stream) (format stream "#" (var-name var-object) (var-kind var-object))) (defun cmpprogress (&rest args) (when *compile-verbose* (apply #'format t args))) (defun cmperr (string &rest args) (let ((c (make-condition 'compiler-error :format-control string :format-arguments args))) (signal c) (print-compiler-message c t) (abort))) (defun check-args-number (operator args &optional (min 0) (max nil)) (let ((l (length args))) (when (< l min) (too-few-args operator min l)) (when (and max (> l max)) (too-many-args operator max l)))) (defun too-many-args (name upper-bound n &aux (*print-case* :upcase)) (cmperr "~S requires at most ~R argument~:p, but ~R ~:*~[were~;was~:;were~] supplied.~%" name upper-bound n)) (defun too-few-args (name lower-bound n) (cmperr "~S requires at least ~R argument~:p, but only ~R ~:*~[were~;was~:;were~] supplied.~%" name lower-bound n)) (defun do-cmpwarn (&rest args) (let ((condition (apply #'make-condition args))) (restart-case (signal condition) (muffle-warning () :REPORT "Skip warning" (return-from do-cmpwarn nil))) (print-compiler-message condition t))) (defun cmpwarn-style (string &rest args) (unless *suppress-compiler-warnings* (do-cmpwarn 'compiler-style-warning :format-control string :format-arguments args))) (defun cmpwarn (string &rest args) (unless *suppress-compiler-warnings* (do-cmpwarn 'compiler-warning :format-control string :format-arguments args))) (defun cmpnote (string &rest args) (unless *suppress-compiler-notes* (do-cmpwarn 'compiler-note :format-control string :format-arguments args))) (defun print-current-form () (when *compile-print* (let ((*print-length* 2) (*print-level* 2)) (format t "~&;;; Compiling ~s.~%" *original-current-form*))) nil) (defun print-emitting (f) (when *compile-print* (let* ((name (or (fun-name f) (fun-description f)))) (when name (format t "~&;;; Emitting code for ~s.~%" name))))) (defun undefined-variable (sym) (do-cmpwarn 'compiler-undefined-variable :name sym)) (defun baboon (&aux (*print-case* :upcase)) (signal 'compiler-internal-error :format-control "A bug was found in the compiler." :format-arguments nil)) (defmacro with-cmp-protection (main-form error-form) `(let* ((si::*break-enable* *compiler-break-enable*) (throw-flag t)) (unwind-protect (multiple-value-prog1 (if *compiler-break-enable* (handler-bind (((and error (not compiler-error)) #'invoke-debugger)) ,main-form) ,main-form) (setf throw-flag nil)) (when throw-flag ,error-form)))) ;; this intercepts any non-local transfer! JCB (defun cmp-eval (form) (with-cmp-protection (eval form) (cmperr "The form ~s was not evaluated successfully.~ ~&You are recommended to compile again." form))) (defun cmp-macroexpand (form &optional (env *cmp-env*)) (with-cmp-protection (handler-case (macroexpand form env) (serious-condition #|program-error|# (condition) ;; program-error was much too weak. JCB (cmperr "Macro expansion of form: ~S~ ~%failed with this condition: ~A." form condition))) (cmperr "The macro form ~S was not expanded successfully.~ ~%You are recommended to compile again." form))) (defun cmp-expand-macro (fd form &optional (env *cmp-env*)) (with-cmp-protection (let ((new-form (handler-case (funcall *macroexpand-hook* fd form env) (serious-condition #|program-error|# (condition) ;; program-error was much too weak. JCB (cmperr "Macro expansion of form: ~S~ ~%failed with this condition: ~A." form condition))))) (values new-form (not (eql new-form form)))) (cmperr "The macro form ~S was not expanded successfully.~ ~%You are recommended to compile again." form))) #-(or mkcl-min mkcl-bootstrap mkcl-cmp-bootstrap) (defun clear-compiler-properties (symbol) (rem-sysprop symbol 't1) (rem-sysprop symbol 't2) (rem-sysprop symbol 't3) (rem-sysprop symbol 'c1) (rem-sysprop symbol 'c2) (rem-sysprop symbol 'c1conditional) (rem-sysprop symbol ':inline-always) (rem-sysprop symbol ':inline-unsafe) (rem-sysprop symbol ':inline-safe) (rem-sysprop symbol 'si::lfun)) (defun lisp-to-c-function-name (obj) "Translate Lisp function name object prin1 representation to valid C function name" #+(or) (and obj (map 'string #'(lambda (c) (let ((cc (char-code c))) (if (or (<= #.(char-code #\a) cc #.(char-code #\z)) (<= #.(char-code #\0) cc #.(char-code #\9))) ;; And you call that mangling! LOL JCB c #\_))) (string-downcase (prin1-to-string obj)))) #+(and) (typecase obj (string (si:mangle-string obj)) (symbol (si:mangle-symbol obj)) (t (si:mangle-string (prin1-to-string obj)))) ;; the (setf foo) case. ) (defun proper-list-p (x &optional test) #+(or) (and (listp x) (handler-case (list-length x) (type-error (c) nil)) (or (null test) (every test x))) ;; This version traverses the list only once and does not create a closure. JCB (and (listp x) (do ((tail x (cdr tail))) ((not (consp tail)) (null tail)) (if test (if (not (funcall test (car tail))) (return nil))) ) ) )