From b9c0f75740c76d3286d89cfaddd92701fea202df Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Mon, 14 May 1990 14:58:13 +0000 Subject: [PATCH] .../systems-work/nnclx/gcontext.lisp, 12-May-90 16:07:22, Edit by Chiles. DEF-GC-INTERNALS could not be defined with a MACROLET due to a compiler bug in handling DEFCONSTANT's. I conditionalized this for CMU back into a DEFMACRO. Added patch to make WITH-GCONTEXT work correctly. You must test the value of ,temp-var (a value a user supplied for some slot) before storing it. Users may supply nil indicating to leave the slot alone. --- clx/gcontext.lisp | 47 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 45 insertions(+), 2 deletions(-) diff --git a/clx/gcontext.lisp b/clx/gcontext.lisp index 41c33a6c2..ad718d121 100644 --- a/clx/gcontext.lisp +++ b/clx/gcontext.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- +;;; -*- Package: XLIB; Log: clx.log -*- ;;; GContext @@ -86,6 +86,9 @@ (defconstant *gcontext-fast-change-length* #.(length *gcontext-components*)) +;;; CMU Common Lisp's old compiler has a bug in compiling DEFCONSTANT's within +;;; MACROLET's. +#-CMU (macrolet ((def-gc-internals (name &rest extras) (let ((macros nil) (indexes nil) @@ -121,6 +124,44 @@ (def-gc-internals ignore (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))) +#+CMU +(defmacro def-gc-internals (name &rest extras) + (let ((macros nil) + (indexes nil) + (masks nil) + (index 0)) + (dolist (name *gcontext-components*) + (push `(defmacro ,(xintern 'gcontext-internal- name) (state) + `(svref ,state ,,index)) + macros) + (setf (getf indexes name) index) + (push (ash 1 index) masks) + (incf index)) + (dolist (extra extras) + (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state) + `(svref ,state ,,index)) + macros) + ;; don't override already correct index entries + (unless (or (getf indexes (second extra)) (getf indexes (first extra))) + (setf (getf indexes (or (second extra) (first extra))) index)) + (push (logior (ash 1 index) + (if (second extra) + (ash 1 (position (second extra) *gcontext-components*)) + 0)) + masks) + (incf index)) + `(within-definition (def-gc-internals ,name) + ,@(nreverse macros) + (eval-when (eval compile load) + (defconstant *gcontext-data-length* ,index) + (defconstant *gcontext-indexes* ',indexes) + (defconstant *gcontext-masks* + ',(coerce (nreverse masks) 'simple-vector)))))) + +#+CMU +(def-gc-internals ignore + (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp)) + ) ;; end EVAL-WHEN (deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*)) @@ -576,7 +617,9 @@ (temp-var (gensym))) (when value (push `(,temp-var ,value) temp-vars) - (push `(setf ,accessor ,temp-var) setfs)))) + (push #-CMU `(setf ,accessor ,temp-var) + #+CMU `(when ,temp-var (setf ,accessor ,temp-var)) + setfs)))) (if setfs `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) -- GitLab