; -*- Mode:Common-Lisp; Package:System-Internals; Base:8.; Patch-File:t; Cold-Load:T -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1987-1989 Texas Instruments Incorporated. All rights reserved. ;; This file contains LISPM Kernel patches needed for the addin support. ;;; ;;; Edit History ;;; ;;; Patch ;;; Date Author Number Description ;;;------------------------------------------------------------------------------ ;;; 12-10-87 ab o DEFINE-WHEN and DEFINE-UNLESS support. ;;; 12-14-87 DNG o :COND fspec handler. ;;; 12.21.87 MBC o Add Test-Disk-Cond function. ;;; 12-22-87 DNG o Fix COND-FSPEC-LOCN to macroexpand the test form. ;;; 01.13.88 MBC o Use :SOUND instead of :SOUND-CHIP. ;;; 01-20-88 ab o Fix RESOURCE-PRESENT-P for :RTC. ;;; 1-21-88 DNG o Fix COND-FSPEC-LOCN for case of function redefined ;;; normally and then redefined conditionally again. ;;; 01-26-88 ab o Added :ENET to *resources-list*. (DEFPARAMETER *resources-list* '(:SIB :DISK :NVRAM :NUBUS :KEYBOARD :MOUSE :RTC :SOUND :ENET)) (DEFMACRO resource-present-p (resource-name) "Returns true if resource RESOURCE-NAME is present; else NIL. RESOURCE-NAME must be a keyword on the sys:*RESOURCES-LIST* list." (DECLARE (SPECIAL *real-time-clock-present*)) (UNLESS (MEMBER resource-name *resources-list*) (FERROR nil "~s is not a valid resource name (see sys:*resources-list*)" resource-name)) ;; Just returns the appropriate symbol to test. (SELECT resource-name (:rtc '*real-time-clock-present*) (:otherwise (INTERN (STRING-APPEND "*" (SYMBOL-NAME resource-name) "-PRESENT*") 'sys))) ) (DEFMACRO resource-dispatch (resource-name function-name &rest args) "If resource RESOURCE-NAME is present invokes a version of function FUNCTION-NAME that is meant to be run in an environment in which the resource is present. Specifically, the function on the RESOURCE-NAME property of the FUNCTION-NAME symbol is applied to ARGS. RESOURCE-NAME must be a keyword on the sys:*RESOURCES-LIST* list." (UNLESS (MEMBER resource-name *resources-list*) (FERROR nil "~s is not a valid resource name (see sys:*resources-list*)" resource-name)) `(FUNCALL (GET ,function-name (if (resource-present-p ,resource-name) ,resource-name ,(INTERN (STRING-APPEND "NO-" (SYMBOL-NAME resource-name)) 'keyword))) ,@args) ) (DEFVAR *load-features* '(*load-sib* *load-disk* *load-nvram* *load-keyboard* *load-mouse* *load-rtc* *load-sound* *load-nubus*)) (DEFUN show-load-features (&optional (stream *standard-output*)) (LOOP for el in *load-features* do (FORMAT stream "~%Feature ~22a ~s" (FORMAT nil "~s:" (first el)) (SYMBOL-VALUE (FIRST el)))) ) (DEFMACRO load-feature-p (load-feature-keyword) (UNLESS (KEYWORDP load-feature-keyword) (FERROR nil "~s is not a keyword." load-feature-keyword)) (COND ((OR (EQ load-feature-keyword :always) (EQ load-feature-keyword :everything)) :always) (t (LET (name str1 str2 pos len resource-name load-sense load-feature-sym) (SETQ name (SYMBOL-NAME load-feature-keyword) len (LENGTH name) pos (POSITION #\- name :test #'EQL) str1 (SUBSEQ name 0 pos) str2 (when (AND pos (< pos len)) (SUBSEQ name (1+ pos) nil)) resource-name (INTERN str1 'keyword) load-sense (COND ((AND str2 (PLUSP (LENGTH (THE string str2)))) (INTERN str2 'keyword)) ((NULL str2) :ON) (t nil))) (UNLESS (MEMBER resource-name *resources-list*) (FERROR nil "~s is not a valid resource name (see sys:*resources-list*)" resource-name)) (SETQ load-feature-sym (INTERN (STRING-APPEND "*LOAD-" (SYMBOL-NAME resource-name) "*") 'sys)) (COND ((OR (EQ load-sense :both) (EQ load-sense :always)) :always) ((EQ load-sense :on) load-feature-sym) ((EQ load-sense :off) `(OR (NULL ,load-feature-sym) (EQ ,load-feature-sym :always))) (t (FERROR nil "~s is not a valid load sense." load-sense)))))) ) (DEFMACRO define-when (load-feature-keyword &body body) "Executes BODY, which should be a defining form, when the load-time parameter corresponding to LOAD-FEATURE-KEYWORD is non-NIL." `(WHEN (load-feature-p ,load-feature-keyword) ,@body) ) (DEFMACRO define-unless (load-feature-keyword &body body) "Executes BODY, which should be a defining form, when the load-time parameter corresponding to LOAD-FEATURE-KEYWORD is NIL or :ALWAYS." `(WHEN (OR (NULL (load-feature-p ,load-feature-keyword)) (EQ :always (load-feature-p ,load-feature-keyword))) ,@body) ) (defprop si:define-when t si:may-surround-defun) (defprop si:define-unless t si:may-surround-defun) ;; From DNG: ;; The function spec (:COND ) names the definition of that ;; will be used when evaluates true. The variable *RUN-TIME-DISPATCH* ;; controls whether the test is evaluated at load time or at run time. (DEFUN (:PROPERTY :COND SI:FUNCTION-SPEC-HANDLER) (OPERATION FUNCTION-SPEC &OPTIONAL ARG1 ARG2) (DECLARE (SPECIAL *run-time-dispatch*)) (IF (NOT (AND (= (LENGTH FUNCTION-SPEC) 3) )) (IF (EQ OPERATION 'VALIDATE-FUNCTION-SPEC) NIL (FERROR 'SYS:INVALID-FUNCTION-SPEC "Invalid function spec ~S." FUNCTION-SPEC)) (LET ((SWITCH (SECOND FUNCTION-SPEC)) (FSPEC (THIRD FUNCTION-SPEC)) ) (CASE OPERATION (VALIDATE-FUNCTION-SPEC (VALIDATE-FUNCTION-SPEC FSPEC)) (FDEFINE (LET ((LOC (COND-FSPEC-LOCN SWITCH FSPEC T))) (UNLESS (NULL LOC) (SETF (CONTENTS LOC) ARG1) (WHEN (SYMBOLP FSPEC) (LET ((DOC (DOCUMENTATION ARG1))) (WHEN (AND DOC (NOT (EQUAL DOC (DOCUMENTATION FSPEC)))) (SETF (DOCUMENTATION FSPEC) DOC))) (LET ((ARGS (ARGLIST ARG1))) (UNLESS (EQUAL (ARGLIST FSPEC) ARGS) (SETF (GET FSPEC 'ARGLIST) ARGS)))) T))) (FDEFINITION (LET ((LOC (COND-FSPEC-LOCN SWITCH FSPEC NIL))) (IF (NULL LOC) (ERROR "Undefined function spec ~S." FUNCTION-SPEC) (CONTENTS LOC)))) (FDEFINEDP (LET ((LOC (COND-FSPEC-LOCN SWITCH FSPEC NIL))) (AND LOC (CONTENTS LOC) T))) (FDEFINITION-LOCATION (COND-FSPEC-LOCN SWITCH FSPEC NIL)) (FUNDEFINE (LET ((LOC (COND-FSPEC-LOCN SWITCH FSPEC NIL))) (UNLESS (NULL LOC) (SETF (CONTENTS LOC) NIL)))) (OTHERWISE (FUNCTION-SPEC-DEFAULT-HANDLER OPERATION FUNCTION-SPEC ARG1 ARG2)) )))) (DEFUN COND-FSPEC-LOCN (SWITCH FSPEC CREATEP) ;; Return a locative to the definition of function spec (:COND switch fspec). ;; Returns NIL if undefined and CREATEP is false. (IF *RUN-TIME-DISPATCH* (MACROLET ((DISPATCH-TABLE-FUNCTION (FSPEC) `(FUNCTION-SPEC-GET ,FSPEC 'DISPATCH-TABLE-FUNCTION))) (DECLARE (INLINE DISPATCH-TABLE-FUNCTION)) (LET (DEFN TBLFN (SWITCH (MACROEXPAND SWITCH *MACROEXPAND-ENVIRONMENT*))) ;; would use MACROEXPAND-ALL except that it is not in the cold load. (WHEN (AND (CONSP SWITCH) (EQ (FIRST SWITCH) 'NOT)) (SETQ SWITCH (LIST (FIRST SWITCH) (MACROEXPAND (SECOND SWITCH) *MACROEXPAND-ENVIRONMENT*)))) (IF (AND (SETQ DEFN (FDEFINITION-SAFE FSPEC T)) (SETQ TBLFN (DISPATCH-TABLE-FUNCTION FSPEC)) (TYPEP DEFN 'LEXICAL-CLOSURE) (EQ (CLOSURE-BINDINGS DEFN) (CLOSURE-BINDINGS TBLFN))) (LET ((TABLE (FUNCALL TBLFN))) (DOLIST (ELT TABLE) (WHEN (EQUAL (FIRST ELT) SWITCH) (RETURN-FROM COND-FSPEC-LOCN (LOCF (SECOND ELT) )))) (AND CREATEP (LET ((ENTRY (LIST SWITCH NIL))) (IF (AND (CONSTANTP SWITCH) (EVAL SWITCH)) (PUSH-END ENTRY TABLE) (PUSH ENTRY TABLE)) (FUNCALL TBLFN TABLE) (LOCF (SECOND ENTRY))))) (WHEN CREATEP (LET ((TABLE (LIST (LIST SWITCH DEFN)))) (WHEN (FDEFINE FSPEC #'(NAMED-LAMBDA DISPATCHER (&REST ARGS) (DOLIST (ELT TABLE (ERROR "Dispatch failure.")) (WHEN (AND (IF (SYMBOLP (FIRST ELT)) (SYMBOL-VALUE (FIRST ELT)) (EVAL (FIRST ELT))) (SECOND ELT)) (RETURN (APPLY (SECOND ELT) ARGS))))) T) (SETF (DISPATCH-TABLE-FUNCTION FSPEC) #'(NAMED-LAMBDA TABLE-ACCESS (&OPTIONAL (VALUE NIL SETP)) (IF SETP (SETQ TABLE VALUE) TABLE))) (LOCF (SECOND (FIRST TABLE))) )))))) ;; else load-time decision (AND (EVAL SWITCH) (LET ((UNCAP (UNENCAPSULATE-FUNCTION-SPEC FSPEC))) (AND (OR CREATEP (FDEFINEDP UNCAP)) (FDEFINITION-LOCATION UNCAP))) ))) ;;; Testing 12.21.87 MBC ;;; ;;; Problems: ;;; 1. Upon first compile of test-disk-cond-at-load with *RUN-TIME-DISPATCH* set to NIL, ;;; and *load-disk* = T, got an error "undefined function: test-disk-cond-at-load" ;;; 2. Functions reloaded, don't always get the new definitions. ;;; 3. A function loaded with *RUN-TIME-DISPATCH* set to T will not be switchable at ;;; runtime, but seems to keep the first version that it started with. ;;(defun (:cond (resource-present-p :disk) test-disk-cond-at-lod) () ;; (format t "~&Test-Disk-Cond Disk ON, current *LOAD-DISK* = ~a" *load-disk*)) ;;(defun (:cond (not (resource-present-p :disk)) test-disk-cond-at-lod) () ;; (format t "~&Test-Disk-Cond Disk OFF, current *LOAD-DISK* = ~a" *load-disk*)) ;;(defun (:cond (resource-present-p :sib) test-sib-cond-hi) () ;; (format t "~&Test-Sib-Cond Sib ON and ON and ON, current *LOAD-SIB* = ~a" *load-sib*)) ;;(defun (:cond (not (resource-present-p :sib)) test-sib-cond-hi) () ;; (format t "~&OFF & OFF Test-Sib-Cond Sib, current *LOAD-SIB* = ~a" *load-sib*))