Skip to content
Snippets Groups Projects
Commit b9c0f757 authored by ram's avatar ram
Browse files

.../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.
parent 4a7d3686
No related branches found
No related tags found
No related merge requests found
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- ;;; -*- Package: XLIB; Log: clx.log -*-
;;; GContext ;;; GContext
...@@ -86,6 +86,9 @@ ...@@ -86,6 +86,9 @@
(defconstant *gcontext-fast-change-length* #.(length *gcontext-components*)) (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) (macrolet ((def-gc-internals (name &rest extras)
(let ((macros nil) (let ((macros nil)
(indexes nil) (indexes nil)
...@@ -121,6 +124,44 @@ ...@@ -121,6 +124,44 @@
(def-gc-internals ignore (def-gc-internals ignore
(:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))) (: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 ) ;; end EVAL-WHEN
(deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*)) (deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*))
...@@ -576,7 +617,9 @@ ...@@ -576,7 +617,9 @@
(temp-var (gensym))) (temp-var (gensym)))
(when value (when value
(push `(,temp-var ,value) temp-vars) (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 (if setfs
`(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc) `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc)
(copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes) (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment