#| -*- Mode:LISP; Base: 10; Package:(VISTA-LIBRARY :use (LISP)); Syntax: Common-lisp; Readtable: CL -*- |# ;;; Copyright (C) Lisp Machine, Inc. 1984, 1985, 1986 ;;; See filename "Copyright" for ;;; licensing and release information. ;;; ******************************************* ;;; ***** PROPRIETARY AND CONFIDENTIAL!!! ***** ;;; ******************************************* (in-package 'vista-library :use '(lisp)) ;;;; Devices and Generic Device Functions (export '(MAKE-DEVICE ;Makes a device of a given type SET-DISPLAY-DEVICE ;Sets the current device to a specified device GET-DISPLAY-DEVICE ;Returns value of *current-display-device* WITH-DISPLAY-DEVICE ;Binds the current device to a specified device )) ;;; Changes: ;;; ??/??/86 EFH Written ;;; 07/03/86 EFH Changed defvice to create accessor macros with optional device args ;;; since Common Lisp defstruct doesn't have the :default-pointer option ;;; 07/11/86 EFH Made devices inherit methods ;;; 10/07/86 PECANN get-display-device ;;; 10/13/86 PECANN export TYPE in DEFVICE ;;; This would all be more elegantly done in an object programming ;;; system but would also be slower. ;;; there should be some way to make this more general ;;; so that you could do it with different non overlapping sets ;;; of operations (defvar *current-display-device*) (defvar *current-display-device-dispatch-table*) (eval-when (eval compile load) (defvar *next-index* -1)) ;;; a DEVICE-TYPE represents a type of device ;;; it will be found on the DEVICE property ;;; of the symbol which is the type name (defstruct DEVICE-TYPE "A device type" (name) (constructor) (dispatch-table) (inheritors ())) ;;; Any instance of a device is a structure which includes this (defstruct (DEVICE (:constructor nil)) ;don't make any of these "A device" (type) (dispatch-table)) ;;; This needs to be better (defun CHECK-DEVICE-TYPE (thing) (if (typep thing 'device) thing (error "~a is not a device" thing))) (defmacro WITH-DISPLAY-DEVICE (device &body body) "Execute BODY with the current display device bound to DEVICE. Any Vista Library commands executed in the body will go to the device." `(let* ((*current-display-device* (check-device-type ,device)) (*current-display-device-dispatch-table* (device-dispatch-table *current-display-device*))) ,@body)) (defun SET-DISPLAY-DEVICE (device) "Set the current display device to DEVICE. All subsequent Vista Library commands will apply to it." (setq *current-display-device* (check-device-type device)) (setq *current-display-device-dispatch-table* (device-dispatch-table device)) device) (defun GET-DISPLAY-DEVICE () *current-display-device*) (defun UNKNOWN-OPERATION (&rest args) (error "There is no DEFVICEFUN for some operation with args:~{ ~s~}" args)) (defun MAKE-DISPATCH-TABLE (&optional (size (max *next-index* 20))) (make-array size :initial-element 'unknown-operation :adjustable t)) (defun COPY-DISPATCH-TABLE (original) (copy-seq original)) ;will the copy be adjustable (defun GROW-DISPATCH-TABLE (dispatch-table size) ;; why doesn't (list size) or (cons size nil) compile into ;; ncons on a lambda? (adjust-array dispatch-table (list size) :initial-element 'unknown-operation)) (defun MAKE-DEVICE-TYPE-IF-NEEDED (type constructor includes) (let* ((included-type (unless (eq includes 'device) (get includes 'device))) (type (or (get type 'device) (setf (get type 'device) (make-device-type :name type :constructor constructor :dispatch-table (if included-type (copy-dispatch-table (device-type-dispatch-table included-type)) (make-dispatch-table))))))) (if included-type (pushnew type (device-type-inheritors included-type))))) ;;; Ignore this ;;; ;;; A defstruct of more than 60 some slots with a callable constructor ;;; creates a function with >60 &key args which won't compile due ;;; to having too many local variables, this constructor just ;;; takes an &rest arg without binding keyword args ;;; (besides having this particular bug, defstruct is pretty gross and ;;; ought to be improved) ;;; ;;; this doesn't use the defstruct-type-descriptions much so ;;; it won't work for as many types ;;; ;;; the reason we don't want to have a generic constructor function is that ;;; we would have to eval (!) the init-form supplied to defstruct ;;; instead of compiling it in line (or else create internal functions ;;; and pass pointers to the generic constructor, yuck!) #+lambda (defmacro nthrev (list n) `(nth ,n ,list)) #+lambda (defmacro define-no-key-constructor (constructor-name defstruct-type) (let* ((keyword-package (find-package 'keyword)) (desc (si:get-defstruct-description defstruct-type)) (slot-alist (si:defstruct-description-slot-alist desc)) ; (named-p (si:defstruct-description-named-p desc)) (type (si:defstruct-description-type desc)) (type-desc (get type 'si:defstruct-type-description)) (overhead (si:defstruct-type-description-overhead type-desc)) (size-form `(+ ,overhead (si:defstruct-description-size ',desc))) (key-list ()) (init-forms ())) (dolist (slotd slot-alist) (push (list (car slotd) (if (si:defstruct-emptyp (si:defstruct-slot-description-init-code (cdr slotd))) nil (si:defstruct-slot-description-init-code (cdr slotd)))) init-forms) (push (intern (symbol-name (car slotd)) keyword-package) key-list)) (setq key-list (nreverse key-list)) (multiple-value-bind (creation-form accessor) (case type (:named-array (values `(make-array ,size-form :named-structure-symbol ',(si:defstruct-description-name desc)) 'aref)) (:named-vector (values `(make-array ,size-form :leader-length 2 :named-structure-symbol ',(si:defstruct-description-name desc)) 'aref)) (:array (values `(make-array ,size-form) 'aref)) (:list (values `(make-list ,size-form) 'nthrev)) (:named-list (values `(cons ',(si:defstruct-description-name desc) (make-list (1- ,size-form))) ;this is awful 'nthrev)) (otherwise (error "I don't understand the type ~s" type))) `(defun ,constructor-name (&rest args) (let ((.struct. ,creation-form) (.slotd.) (.name.) (.key.) (.find-key.)) (do ((.alist. (si:defstruct-description-slot-alist ',desc) (cdr .alist.)) (.key-list. ',key-list (cdr .key-list.))) ((null .alist.)) (setq .name. (caar .alist.) .slotd. (cdar .alist.) .key. (car .key-list.)) (setf (,accessor .struct. (+ ,overhead (si:defstruct-slot-description-number .slotd.))) (if (setq .find-key. (member .key. args :test #'eq)) (cadr .find-key.) (case .name. ,@init-forms)))) .struct.))))) (defun get-option-args (option options) (dolist (opt options) (when (and (listp opt) (eq (car opt) option)) (return (cdr opt))))) (defmacro DEFVICE (type &body items) "Define a device type" (let* ((options (if (listp type) (prog1 (cdr type) (setq type (car type))))) (%constructor (intern (format nil "%MAKE-~a" type))) (constructor (intern (format nil "MAKE-~a" type))) (conc-name (or (car (get-option-args :conc-name options)) (format nil "~a-" (symbol-name type)))) (%conc-name (concatenate 'string "%" conc-name)) (included (or (car (get-option-args :include options)) 'device)) (include-slots (cdr (get-option-args :include options)))) #+lispm (declare (ignore %conc-name)) `(progn (make-device-type-if-needed ',type ',constructor ',included) (defstruct (,type (:include ,included (type (get ',type 'device)) (dispatch-table (device-type-dispatch-table (get ',type 'device))) ,@include-slots) (:conc-name #+lispm ,conc-name #-lispm ,(intern %conc-name)) (:constructor #+lambda () #-lambda ,%constructor) (:copier nil) (:print-function print-device) #+lispm (:default-pointer *current-display-device*)) ;not in Common Lisp ,(if (stringp (car items)) (pop items) (format nil "A device of type ~a" type)) ,@items) #-lispm ,@(mapcar #'(lambda (slot) (let ((slot-name (symbol-name (if (symbolp slot) slot (car slot))))) `(defmacro ,(intern (concatenate 'string conc-name slot-name)) (&optional (device '*current-display-device*)) `(,',(intern (concatenate 'string %conc-name slot-name)) ,device)))) items) #+lambda (define-no-key-constructor ,%constructor ,type) (export ',type) (export ',constructor) (defun ,constructor (&rest args) (let ((new-device (apply #',%constructor args))) (with-display-device new-device (init new-device)) new-device))))) (defun MAKE-DEVICE (device-type &rest inits) "Make an instance of a device of the given type" (apply (device-type-constructor (get device-type 'device)) inits)) (defun PRINT-DEVICE (device stream depth) (declare (ignore depth)) (format stream "#<~a Device ~a>" (type-of device) #+lispm (zl:%pointer device) #-lispm "")) (eval-when (eval compile load) (defmacro DEFINDEX (operation index) "Define an operation to have certain index" `(defindex-1 ',operation ,index)) (defun defindex-1 (operation index) (export operation) (setf (get operation 'device-op-index) index) (if (< *next-index* index) (setq *next-index* index)))) (defmacro DEFVICEOP (operation lambda-list &rest decls-or-doc) "Define a generic function and index for the operation. A defviceop for the operation must occur before any defvicefun for that operation (sorry)." (let ((index (or (get operation 'device-op-index) (incf *next-index*)))) `(eval-when (eval compile load) ;need defsubst at compile time ; #-LispM (proclaim '(inline ,operation)) does this work??? (#+LispM zl:defsubst #-LispM defun ,operation ,(when lambda-list '(&rest args)) (declare (#+lispm zl:arglist #-lispm arglist ,@lambda-list)) ;??? ,@decls-or-doc ,(if lambda-list `(apply (aref *current-display-device-dispatch-table* ,index) args) `(funcall (aref *current-display-device-dispatch-table* ,index)))) (defindex ,operation ,index)))) (defun SET-DEVICE-METHOD (device-type operation function) "Sets the method for on to be must already have an index" (let* ((type (get device-type 'device)) (dispatch-table (device-type-dispatch-table type)) (inheriting-dispatch-tables (mapcar #'device-type-dispatch-table (device-type-inheritors type))) (index (get operation 'device-op-index))) (if (null index) (error "~a has no index, a DEFVICEOP needs to be done first" operation)) (let ((old-fcn (if (< index (length dispatch-table)) (aref dispatch-table index) nil))) (%set-device-method (if (symbolp function) (setq function (symbol-function function)) function) index dispatch-table) (dolist (table inheriting-dispatch-tables) (if (eq (aref table index) old-fcn) ;don't replace shadowed methods (%set-device-method function index table)))))) (defun %SET-DEVICE-METHOD (function index dispatch-table) (if (>= index (length dispatch-table)) (grow-dispatch-table dispatch-table (1+ index))) (setf (aref dispatch-table index) function)) (defconstant *device-method-package* (or (find-package "Device Method") (make-package "Device Method" :use ())) "A package containing the names for all device methods") (defmacro DEFVICEFUN ((operation device-type) lambda-list &body body) "Define a device function, a method for an operation on a specific device type." (let ((fname (intern (format nil "~a ~a" operation device-type) *device-method-package*))) `(progn (defun ,fname ,lambda-list ;(:location ,(aloc dispatch-table index)) ,@body) (set-device-method ',device-type ',operation ',fname)))) (defviceop INIT (&rest args) "Initialize the device. This is called when a device is created")