;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.87 ;;; Reason: ;;; Further rationalize/fix style checkers (and some optimizers), ;;; particularly some broken argument checkers, e.g. SIGNP, FORMAT. ;;; Written 16-Sep-88 16:47:54 by keith at site Gigamos Cambridge ;;; while running on Johannes Brahms from band 3 ;;; with Experimental System 126.86, Experimental ZWEI 126.10, Experimental ZMail 74.1, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, Lambda/Falcon Development System. ; From modified file DJ: L.SYS; QCOPT.LISP#182 at 16-Sep-88 16:50:00 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defoptimizer =-optimizer = (form) (let* ((args (cdr form)) (n-args (length args))) (cond ((< n-args 2) (warn 'wrong-number-of-arguments :implausible "~S called with too few arguments" (car form)) ''t) ((= n-args 2) (cond ((eq (first args) 0) `(zerop ,(second args))) ((eq (second args) 0) `(zerop ,(first args))) (t `(internal-= . ,args)))) ((cl:every #'trivial-form-p (cdr args)) `(and . ,(loop for arg in (cdr args) and for last-arg first (car args) then arg collect `(internal-= ,last-arg ,arg)))) (t form)))) )) ; From modified file DJ: L.SYS; QCOPT.LISP#182 at 16-Sep-88 16:51:38 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defun (:property format style-checker) (form) ;;This gets caught by compiler ;;(need-two-args form) ;;>> It would be -kind- of nice to parse the format string for syntactic illegality... (if (typep (cadr form) '(or string number array)) (warn 'bad-argument ':implausible "~S ~called with ~S as its first argument,~&~ which should be ~S, ~S, a stream, or a string with fill-pointer~" 'format (cadr form) t nil))) )) ; From modified file DJ: L.SYS; QCP1.LISP#729 at 16-Sep-88 16:52:28 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (DEFUN CHECK-NUMBER-OF-ARGS (FORM &OPTIONAL FUNCTION) (IF (NULL FUNCTION) (SETQ FUNCTION (CAR FORM))) (LET* (TEM ARGLIST NARGS (MIN NIL) (MAX 0) (MAX1 0) (ARGS-INFO NIL) (LOCALP NIL) (FN FUNCTION)) (AND (SYMBOLP FN) ;; If FN is a name defined lexically by FLET or LABELS, use its definition. (SETQ LOCALP (FSYMEVAL-IN-FUNCTION-ENVIRONMENT FN)) (SETQ FN LOCALP)) (FLET ((BAD-ARGUMENTS (MSG) (WARN 'WRONG-NUMBER-OF-ARGUMENTS :PROBABLY-ERROR (IF LOCALP "~S (locally defined function) called with ~A" "~S called with ~A") (CAR FORM) MSG))) (TAGBODY TOP (IF LOCALP (SETQ ARGLIST (CASE (CAR FN) ((MACRO) (RETURN-FROM CHECK-NUMBER-OF-ARGS NIL)) ((NAMED-LAMBDA NAMED-SUBST) (CADDR FN)) (T (CADR FN)))) (SETQ FN (LAMBDA-MACRO-EXPAND FN)) (COND ((AND (SYMBOLP FN) (NOT (FBOUNDP FN))) (SETQ ARGLIST NIL)) (T (SETQ ARGLIST (IGNORE-ERRORS (ARGLIST FN 'COMPILE))) (IF (EQ ARGLIST 'MACRO) (RETURN-FROM CHECK-NUMBER-OF-ARGS NIL))))) (COND ((OR LOCALP (MEMQ (CAR-SAFE FN) '(LAMBDA NAMED-LAMBDA ZL:SUBST CL:SUBST NAMED-SUBST))) (DOLIST (X ARGLIST) (COND ((EQ X '&OPTIONAL) (SETQ MIN MAX)) ((OR (EQ X '&REST) (EQ X '&BODY) (EQ X '&KEY)) (UNLESS MIN (SETQ MIN MAX)) (SETQ MAX MOST-POSITIVE-FIXNUM) (RETURN)) ((EQ X '&AUX) (RETURN)) ((MEMQ X LAMBDA-LIST-KEYWORDS)) (T (INCF MAX) (INCF MAX1))))) ((NOT (SYMBOLP FN)) ;; Unknown type, don't check (RETURN-FROM CHECK-NUMBER-OF-ARGS NIL)) ((SETQ TEM (GET FN 'ARGDESC)) (DOLIST (X TEM) (COND ((MEMQ 'FEF-ARG-REQ (CADR X)) (INCF MAX (CAR X)) (INCF MAX1 (CAR X))) ((MEMQ 'FEF-ARG-OPT (CADR X)) (OR MIN (SETQ MIN MAX)) (INCF MAX (CAR X)) (INCF MAX1 (CAR X))) ((MEMQ 'FEF-ARG-REST (CADR X)) (OR MIN (SETQ MIN MAX)) (SETQ MAX MOST-POSITIVE-FIXNUM))))) ((SETQ TEM (GET FN 'QINTCMP)) (SETQ MAX TEM MAX1 TEM)) ;>> used?? ((SETQ TEM (GET FN 'Q-ARGS-PROP)) (SETQ ARGS-INFO TEM)) ;; Take care of recursive calls to function being compiled. ((AND (EQ FN THIS-FUNCTION-ARGLIST-FUNCTION-NAME) (NOT LOCALP)) (DOLIST (X THIS-FUNCTION-ARGLIST) (COND ((EQ X '&OPTIONAL) (SETQ MIN MAX)) ((OR (EQ X '&REST) (EQ X '&BODY) (EQ X '&KEY)) (UNLESS MIN (SETQ MIN MAX)) (SETQ MAX MOST-POSITIVE-FIXNUM) (RETURN)) ((EQ X '&AUX) (RETURN)) ((MEMQ X LAMBDA-LIST-KEYWORDS)) (T (INCF MAX) (INCF MAX1))))) ;;>> doesn't look at definitions earlier in the file ((FBOUNDP FN) (SETQ TEM (SI:UNENCAPSULATE-FUNCTION-SPEC FN)) (UNLESS (EQ TEM FN) (SETQ FN TEM) (GO TOP)) (SETQ TEM (SYMBOL-FUNCTION FN)) (COND ((OR (SYMBOLP TEM) (CONSP TEM)) (SETQ FN TEM) (GO TOP)) (T (SETQ ARGS-INFO (%ARGS-INFO TEM))))) (T ;;No information available (RETURN-FROM CHECK-NUMBER-OF-ARGS NIL)))) (WHEN ARGS-INFO (SETQ MIN (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO) MAX1 (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO) MAX (IF (BIT-TEST (LOGIOR %ARG-DESC-QUOTED-REST %ARG-DESC-EVALED-REST) ARGS-INFO) MOST-POSITIVE-FIXNUM MAX1))) (SETQ NARGS (LENGTH (CDR FORM))) ;Now that we know it's not a macro (COND ((< NARGS (OR MIN MAX)) (BAD-ARGUMENTS "too few arguments")) ((> NARGS MAX) (BAD-ARGUMENTS "too many arguments")) ((CONSP ARGLIST) (LET* ((KEYARGS (MEMQ '&KEY ARGLIST)) (KEYFORM (NTHCDR (OR MAX1 MIN) (CDR FORM)))) (WHEN (AND KEYARGS KEYFORM) (IF (ODDP (LENGTH KEYFORM)) (BAD-ARGUMENTS "no value supplied for some keyword argument") (LET ((ALLOW-OTHER-KEYS (OR (MEMQ '&ALLOW-OTHER-KEYS ARGLIST) (GETF KEYFORM ':ALLOW-OTHER-KEYS)))) (LOOP FOR KEY IN KEYFORM BY 'CDDR WHEN (AND (EQ (CAR-SAFE KEY) 'QUOTE) (SELF-EVALUATING-P (CADR KEY))) DO (SETQ KEY (CADR KEY)) DOING (COND ((KEYWORDP KEY) (UNLESS (OR ALLOW-OTHER-KEYS (DOLIST (X KEYARGS) (IF (MEMQ X LAMBDA-LIST-KEYWORDS) NIL (IF (IF (CONSP X) (IF (CONSP (CAR X)) ;; ((:frob foo) bar) (EQ KEY (CAAR X)) ;; (foo bar) (STRING= KEY (CAR X))) ;; foo (STRING= KEY X)) (RETURN T))))) (BAD-ARGUMENTS (FORMAT NIL "the unrecognized keyword ~S" KEY)))) ((SELF-EVALUATING-P KEY) (BAD-ARGUMENTS (FORMAT NIL "~S appearing where a keyword should" KEY)))))))))))))) )) ; From modified file DJ: L.SYS; QCOPT.LISP#182 at 16-Sep-88 17:02:13 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defun arithexp (x &aux (l (length (cdr x))) (op (get (car x) 'two-argument-function))) (cond ((null op) (barf x 'bad-op-arithexp 'barf)) ((= 0 l) (or (setq l (assq op '((*plus . 0) (*dif . 0) (*times . 1) (*quo . 1) (%div . 1)))) (warn 'bad-arithmetic ':implausible "~S called with no arguments" x)) (cdr l)) ((= l 1) (case (car x) (- `(minus ,(cadr x))) (// `(*quo 1 ,(cadr x))) (cl:// `(%div 1 ,(cadr x))) (t (cadr x)))) ;+ * logior logxor logand mix max ((= l 2) `(,op . ,(cdr x))) (t `(,op (,(car x) . ,(butlast (cdr x))) . ,(last x))))) )) ; From modified file DJ: L.SYS; QCOPT.LISP#182 at 16-Sep-88 17:19:02 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  " (defrewrite signp-expand signp (x) (or (= (length x) 3) (warn 'bad-signp ':impossible "SIGNP called with too ~:[few~;many~] arguments" (> (length x) 3))) (let ((operation (cadr x)) (operand (caddr x)) new-form notp) (cond ((atom operand) (setq new-form `(,(cond ((string-equal operation 'e) 'zerop) ((string-equal operation 'n) (setq notp t) 'zerop) ((string-equal operation 'l) 'minusp) ((string-equal operation 'ge) (setq notp t) 'minusp) ((string-equal operation 'g) 'plusp) ((string-equal operation 'le) (setq notp t) 'plusp) (t (warn 'bad-signp ':impossible "~S called with invalid condition ~S" 'signp operation) 'progn)) ,operand)) (if notp (setq new-form `(not ,new-form))) `(and (numberp ,operand) ,new-form)) ('else ;; *MUST* open compile this to avoid call to gross interpreter special form. (let ((g (gentemp "operand"))) `(let ((,g ,operand)) (signp ,operation ,g))))))) ))