;;; -*- Mode:Common-Lisp; Package:SYSTEM; Base:10; Patch-file:T -*- ;;; Reason: Faster UNION with :TEST #'EQ. Export MEMQ from SYS. ;;; Update INSTANTIATE-FLAVOR to permit instantation-flavor-function to return an actual instance. ;;; 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, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Patch file for REL6H version 6.11 ;;; Written 05/08/89 12:23:30 by GRAY, ;;; while running on Kelvin from band LOD2 ;;; With Experimental REL6H 6.10, Experimental SYSTEM 6.0, Experimental VIRTUAL-MEMORY 6.0, ;;; Experimental EH 6.0, Experimental MAKE-SYSTEM 6.0, Experimental MICRONET 6.0, ;;; Experimental LOCAL-FILE 6.0, Experimental BASIC-PATHNAME 6.0, Experimental NETWORK-SUPPORT-COLD 6.0, ;;; Experimental BASIC-NAMESPACE 6.0, Experimental NETWORK-NAMESPACE 6.0, Experimental DISK-IO 6.0, ;;; Experimental DISK-LABEL 6.0, Experimental BASIC-FILE 6.0, Experimental MAC-PATHNAME 6.0, ;;; Experimental NETWORK-PATHNAME 6.0, Experimental COMPILER 6.0, Experimental TV 6.0, ;;; Experimental DATALINK 6.0, Experimental CHAOSNET 6.0, Experimental GC 6.0, Experimental MEMORY-AUX 6.0, ;;; Experimental NVRAM 6.0, Experimental SYSLOG 6.0, Experimental STREAMER-TAPE 6.0, ;;; Experimental CLEH 1.0, Experimental UCL 6.0, Experimental INPUT-EDITOR 6.0, Experimental METER 6.0, ;;; Experimental ZWEI 6.0, Experimental DEBUG-TOOLS 6.0, Experimental NETWORK-SUPPORT 6.0, ;;; Experimental NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, Experimental FONT-EDITOR 6.0, ;;; Experimental SERIAL 6.0, Experimental PRINTER 6.0, Experimental MAC-PRINTER-TYPES 6.0, ;;; Experimental PRINTER-TYPES 6.0, Experimental IMAGEN 6.0, Experimental SUGGESTIONS 6.0, ;;; Experimental MAIL-DAEMON 6.0, Experimental MAIL-READER 6.0, Experimental TELNET 6.0, ;;; Experimental VT100 6.0, Experimental NAMESPACE-EDITOR 6.0, Experimental PROFILE 6.0, ;;; VISIDOC 6.0, Experimental TI-CLOS 17.4, Experimental CLX 5.0, Experimental CLUE 20.0, ;;; Experimental X11M 3.0, Experimental RPC 6.0, Experimental NFS 6.0, Experimental BUG 11.4, ;;; IP 3.45, Experimental DOCUMENTER 619.0, microcode 426, Band Name: Rel6H,Scribe, ;;; &c, u426 5/4 ;; first remove extraneous symbols so the EXPORT below will succeed. (dolist (p '("SYS" "TV")) (let* ((pkg (find-package p)) (sym (find-symbol "MEMQ" pkg))) (when (and sym (not (fboundp sym)) (null (symbol-plist sym)) (not (boundp sym))) (unintern sym pkg)))) #!C ; From file LOOP.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; LOOP.#" (export '(zlc:memq) "SYS") ; 5/8/89 DNG [not really related to LOOP but needs to be in aux-crash list.] )) #!C ; From file LISTS.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; LISTS.#" ;; 5/05/89 DNG - Add special case for :TEST #EQ, which makes it twice as ;; fast. This is used a lot by both Flavors and TICLOS. (Defun UNION* (list1 list2 &OPTIONAL (test #'EQL) key test-not) (IF (NULL list2) list1 (IF key (UNION-TEMPLATE (MEMBER* (FUNCALL key (CAR x)) list2 test key test-not)) (if (eq test #'eq) (UNION-TEMPLATE (ZLC:MEMQ (CAR x) list2)) (UNION-TEMPLATE (MEMBER* (CAR x) list2 test key test-not)))))) )) #!C ; From file RUNTIME-FLAVOR.LISP#> KERNEL; MR-X: #8R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; RUNTIME-FLAVOR.#" ;; 5/07/89 DNG - Permit the instantiation-flavor-function to return an instance. (defun instantiate-flavor (flavor init-plist &optional send-init-message-p return-unhandled-keywords-p;as second value area-to-cons-instance-in &aux fl unhandled-keywords instance vars new-plist plist) "Create and return an instance of the specified FLAVOR, low level. INIT-PLIST's CDR is the list of init keywords and their values. This list will be modified destructively so that any default init plist keywords (except those that just set instance variables) are on it. We send a :INIT message only if SEND-INIT-MESSAGE-P is non-nil. That may further modify the INIT-PLIST. If RETURN-UNHANDLED-KEYWORDS-P is non-nil, our second value is an alternating list of keywords and values for those keywords specified in INIT-PLIST (or in the default init plist) which the flavor doesn't handle. If RETURN-UNHANDLED-KEYWORDS-P is nil, it is an error if there are any such. FLAVOR may also be a flavor instance, instead of a flavor name. In this case the instance is reinitialized using INIT-PLIST, and a new flavor instance is NOT created." ;;If user supplied first arg a flavor instance, use it instead of creating a new instance. (if (typep flavor 'instance) (progn (setq instance flavor flavor (type-of instance) fl (get-flavor-tracing-aliases flavor) vars (flavor-all-instance-variables fl)) ;; Default all instance variables to unbound (do ((v vars (cdr v)) (i 1 (1+ i))) ((null v)) (%p-store-tag-and-pointer (%make-pointer-offset dtp-locative instance i) dtp-null (car v)))) ;; Trace any chain of alias flavors to a non-alias flavor. (progn (check-arg flavor (setq fl (get-flavor-tracing-aliases flavor)) "the name of an instantiable flavor, or alias thereof, or a flavor instance to be reinitialized.") (setf plist (flavor-plist fl)) (let ((tem (getf plist :instantiation-flavor-function))) (when tem (setq tem (funcall tem fl init-plist)) (unless (and (symbolp tem) (get tem 'flavor)) (when (instancep tem) (return-from instantiate-flavor tem)) (error "The INSTANTIATION-FLAVOR-FUNCTION for flavor ~S returned an invalid value, ~S, not a flavor name or instance." flavor)) (setq flavor tem fl (get-flavor-tracing-aliases flavor)))) (when (getf plist :abstract-flavor) (ferror () "~S is an abstract flavor (or alias of one) and may not be instantiated." flavor)) (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) (typecase (flavor-method-hash-table fl) (array nil) (cons (make-method-hash-table fl)) (null (compose-method-combination fl)) (t nil)) (unless area-to-cons-instance-in (setq area-to-cons-instance-in (and (getf plist 'instance-area-function) (funcall (getf plist 'instance-area-function) init-plist)))) (let ((missing-keywords (remove-if #'(lambda (keyword) (get-location-or-nil init-plist keyword)) (getf plist 'required-init-keywords)))) (when missing-keywords (ferror () "Flavor ~S requires init keywords ~S that are missing." flavor missing-keywords))) (setq instance (%allocate-and-initialize-instance; fl area-to-cons-instance-in (flavor-instance-size fl)))) ;; Make the instance object, then fill in its various fields ; (FUNCALL (OR (GETF PLIST 'INSTANCE-AREA-FUNCTION) 'IGNORE) ; INIT-PLIST))) ;; Do any composition (compilation) of combined stuff, if not done already ); (SETQ VARS (FLAVOR-ALL-INSTANCE-VARIABLES FL))) ;; Default all instance variables to unbound ; (DO ((V VARS (CDR V)) ; (I 1 (1+ I))) ; ((NULL V)) ; (%P-STORE-TAG-AND-POINTER (%MAKE-POINTER-OFFSET DTP-LOCATIVE INSTANCE I) ; DTP-NULL (CAR V))) (setq unhandled-keywords (flavor-unhandled-init-keywords fl)) (let ((var-keywords (flavor-all-inittable-instance-variables fl)) (remaining-keywords (flavor-remaining-init-keywords fl))) ;; First, process any user-specified init keywords that ;; set instance variables. When we process the defaults, ;; we will see that these are already set, and will ;; refrain from evaluating the default forms. ;; At the same time, we record any init keywords that this flavor doesn't handle. (do ((pl (cdr init-plist) (cddr pl))) ((null pl)) (let ((index (position (car pl) (the list var-keywords) :test #'eq))) (cond (index (or (/= dtp-null (%p-data-type (%instance-loc instance (1+ index)))) (setf (%instance-ref instance (1+ index)) (cadr pl)))) ((not (member (car pl) remaining-keywords :test #'eq)) (pushnew (car pl) unhandled-keywords))))) ;; Now do all the default initializations, of one sort or other, ;; that have not been overridden. (let ((self instance)) (dolist (d (flavor-instance-variable-initializations fl)) (or (/= dtp-null (%p-data-type (%instance-loc instance (1+ (car d))))) (setf (%instance-ref instance (1+ (car d))) (fast-eval (cadr d))))) ;; Now stick any default init plist items that aren't handled by that ;; onto the actual init plist. (do ((pl (flavor-remaining-default-plist fl) (cddr pl))) ((null pl)) (or (memq-alternated (car pl) (cdr init-plist)) (progn (unless (eq init-plist (locf new-plist)) (setq new-plist (cdr init-plist) init-plist (locf new-plist))) (setq new-plist (list* (car pl) (fast-eval (cadr pl)) new-plist))))))) ;; Complain if any keywords weren't handled, unless our caller ;; said it wanted to take care of this. (and (not return-unhandled-keywords-p) unhandled-keywords (not (get init-plist :allow-other-keys)) (ferror () "Flavor ~S does not handle the init keyword~P ~{~S~^, ~}" flavor (length unhandled-keywords) unhandled-keywords)) (if send-init-message-p (send instance :init init-plist)) (values instance unhandled-keywords)) ))