;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.110 ;;; Reason: ;;; Implement style checks on DEFSTRUCT. Gives intelligible warnings about ;;; malformed structure names and subslots (e.g. invalid byte fields). ;;; Written 14-Oct-88 18:58:15 by keith (Keith Corbett) at site Gigamos Cambridge ;;; while running on Breaking Glass from band 3 ;;; with Experimental System 126.108, Experimental ZWEI 126.19, Experimental ZMail 74.9, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, Experimental IMicro 20.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103. ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:58:28 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defun check-byte-spec (form &optional (fcn (car form)) (warn t) &aux flag) (let* ((argpos (or (get fcn 'check-byte-spec-arg) 0)) (barg (nth (1+ argpos) form)) (definitely-not-portable t)) (when (setq flag ;;Return to FLAG the warning, if any (macrolet ((middle (prefix) (format nil "~A ~~S as a BYTE specifier" prefix)) (at-end (prefix) (format nil "~A BYTE specifier /"~~S/"" prefix)) (simple (prefix) (format nil "~A BYTE specifier~~*" prefix))) (typecase barg (keyword (middle "the keyword")) ;Keywords will never be right ((member t nil) ; T, NIL other selv-evaling vars (if barg (simple "T as a") (simple "a null"))) (symbol nil) ;Variables? We can't be sure. (list ;"Random" function calls are not portable. (setq barg (car barg)) (cond ((get barg 'legal-byte-specifier) nil) ;The ideal: calls to BYTE (t (setq definitely-not-portable nil) ;Can't be sure (middle "a call to")))) (number (middle "the numeric constant")) ;Numbers (t (at-end "an invalid"))))) (let ((msg (format nil "~@[~S called with ~]~A (this ~:[may not be~;is not~] portable)" fcn (format nil flag barg) definitely-not-portable))) (if warn (warn 'invalid-byte-spec :not-portable msg) msg))))) ;;;Put the LEGAL-BYTE-SPECIFIER property on things like BYTE that return ;;;portable, legally formatted byte specifiers -- i.e., they don't do any ;;;processor-specific arithmetic. )) ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:58:51 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defun (:property make-array style-checker) (form &aux type) ;;Handle quoted and keyword forms of :TYPE :ART-Q-LIST (and (setq type (or (getf (cddr form) :type) (cadr (member '(quote :type) (cddr form))))) (or (equal type '(quote art-q-list)) (and (symbolp type) (string-equal type :art-q-list))) (warn 'art-q-list-warning :not-portable "~S called with :TYPE ART-Q-LIST (this may not be portable)" (car form)))) ;;; This will actually come in pretty handy when LISP:MAP is open-coded for vectors. )) ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:59:02 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defconstant *defstruct-style-warning* 'defstruct-style-warning) )) ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:59:02 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defvar *defstruct-check-name* nil) )) ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:59:03 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defmacro defstruct-check-warn (severity msg &rest args) (declare (zwei:indentation 1 1)) `(warn *defstruct-style-warning* ,severity (format nil "DEFSTRUCT~@[ ~A~]: ~A" *defstruct-check-name* ,msg) ,@args)) )) ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:59:03 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defun defstruct-check-name (form &optional (warn t)) (let ((name (second form))) (if (consp name) (setq name (first name))) (cond ((symbolp name) (setq *defstruct-check-name* name) nil) ((null warn) nil) (t (defstruct-check-warn nil :implausible "Invalid name ~S" name))))) )) ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:59:04 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defun defstruct-check-no-byte-fields (form) (let ((slots (cddr form))) (dolist (slot slots) (when (consp (car slot)) ;probably a byte field (return (defstruct-check-warn :not-portable "contains subslot fields (this may not be portable)")))))) )) ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:59:04 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defun defstruct-check-valid-byte-fields (form) (let ((slots (cddr form))) (dolist (slot slots) (when (consp (car slot)) (dolist (subslot slot) (and (second subslot) (let ((flag (check-byte-spec subslot nil nil))) (when flag (return (defstruct-check-warn :not-portable "invalid byte spec -- ~A" flag)))))))))) )) ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:59:05 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defun defstruct-style-checker (form) (let ((commonlisp-p (eq (car form) 'lisp:defstruct)) (*defstruct-check-name* nil)) ;;;OR through cases so multiple values get passed (or (defstruct-check-name form) (if commonlisp-p (defstruct-check-no-byte-fields form)) (defstruct-check-valid-byte-fields form)))) )) ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:59:06 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (putprop 'lisp:defstruct 'defstruct-style-checker 'style-checker) )) ; From modified file DJ: L.SYS; QCOPT.LISP#187 at 14-Oct-88 18:59:06 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (putprop 'zl:defstruct 'defstruct-style-checker 'style-checker) ))