From eecb8c533a2686c82844b7e5c30dff419906fb48 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Sat, 3 Nov 1990 03:17:32 +0000
Subject: [PATCH] Initial revision

---
 compiler/generic/objdef.lisp   | 414 +++++++++++++++++++++++++++++++++
 compiler/generic/primtype.lisp | 254 ++++++++++++++++++++
 compiler/generic/utils.lisp    |  57 +++++
 3 files changed, 725 insertions(+)
 create mode 100644 compiler/generic/objdef.lisp
 create mode 100644 compiler/generic/primtype.lisp
 create mode 100644 compiler/generic/utils.lisp

diff --git a/compiler/generic/objdef.lisp b/compiler/generic/objdef.lisp
new file mode 100644
index 000000000..a169d794d
--- /dev/null
+++ b/compiler/generic/objdef.lisp
@@ -0,0 +1,414 @@
+;;; -*- Package: VM; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.1 1990/11/03 03:15:57 wlott Exp $
+;;;
+;;; This file contains the machine independent aspects of the object
+;;; representation.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "VM")
+
+(export '(lowtag-bits lowtag-mask lowtag-limit type-bits type-mask
+	  primitive-object primitive-object-p primitive-object-name
+	  primitive-object-header primitive-object-lowtag
+	  primitive-object-options primitive-object-slots
+	  primitive-object-size primitive-object-variable-length
+	  slot-name slot-docs slot-rest-p slot-offset slot-length
+	  slot-options define-for-each-primitive-object))
+
+
+
+;;;; Type based constants:
+
+(eval-when (compile eval load)
+
+(defconstant lowtag-bits 3
+  "Number of bits at the low end of a pointer used for type information.")
+
+(defconstant lowtag-mask (1- (ash 1 lowtag-bits))
+  "Mask to extract the low tag bits from a pointer.")
+  
+(defconstant lowtag-limit (ash 1 lowtag-bits)
+  "Exclusive upper bound on the value of the low tag bits from a
+  pointer.")
+
+(defconstant type-bits 8
+  "Number of bits used in the header word of a data block for typeing.")
+
+(defconstant type-mask (1- (ash 1 type-bits))
+  "Mask to extract the type from a header word.")
+
+); eval-when
+
+
+(defparameter target-most-positive-fixnum (1- (ash 1 29))
+  "most-positive-fixnum in the target architecture.")
+
+(defparameter target-most-negative-fixnum (ash -1 29)
+  "most-negative-fixnum in the target architecture.")
+
+
+;;; The main types.  These types are represented by the low three bits of the
+;;; pointer or immeditate object.
+;;; 
+(defenum (:suffix -type)
+  even-fixnum
+  function-pointer
+  other-immediate-0
+  list-pointer
+  odd-fixnum
+  structure-pointer
+  other-immediate-1
+  other-pointer)
+
+;;; The heap types.  Each of these types is in the header of objects in
+;;; the heap.
+;;; 
+(defenum (:suffix -type
+	  :start (+ (ash 1 lowtag-bits) other-immediate-0-type)
+	  :step (ash 1 (1- lowtag-bits)))
+  bignum
+  ratio
+  single-float
+  double-float
+  complex
+  
+  simple-array
+  simple-string
+  simple-bit-vector
+  simple-vector
+  simple-array-unsigned-byte-2
+  simple-array-unsigned-byte-4
+  simple-array-unsigned-byte-8
+  simple-array-unsigned-byte-16
+  simple-array-unsigned-byte-32
+  simple-array-single-float
+  simple-array-double-float
+  complex-string
+  complex-bit-vector
+  complex-vector
+  complex-array
+  
+  code-header
+  function-header
+  closure-header
+  funcallable-instance-header
+  unused-function-header-1
+  unused-function-header-2
+  unused-function-header-3
+  closure-function-header
+  return-pc-header
+  value-cell-header
+  symbol-header
+  base-character
+  sap
+  unbound-marker
+  weak-pointer
+  structure-header)
+
+
+;;; The different vector subtypes.
+;;; 
+(defenum (:prefix vector- :suffix -subtype)
+  normal
+  unused
+  valid-hashing
+  must-rehash)
+
+
+
+
+;;;; Primitive data objects definition noise.
+
+(eval-when (compile load eval)
+
+(defstruct (slot
+	    (:constructor %make-slot
+			  (name docs rest-p length options)))
+  (name nil :type symbol)
+  (docs nil :type (or null simple-string))
+  (rest-p nil :type (member t nil))
+  (offset 0 :type fixnum)
+  (length 1 :type fixnum)
+  (options nil :type list))
+
+(defun make-slot (name &rest options
+		       &key docs rest-p (length (if rest-p 0 1))
+		       &allow-other-keys)
+  (remf options :docs)
+  (remf options :rest-p)
+  (remf options :length)
+  (%make-slot name docs rest-p length options))
+
+(defstruct (primitive-object
+	    )
+  (name nil :type symbol)
+  (header nil :type symbol)
+  (lowtag nil :type symbol)
+  (options nil :type list)
+  (slots nil :type list)
+  (size 0 :type fixnum)
+  (variable-length nil :type (member t nil)))
+
+
+(defvar *primitive-objects* nil)
+
+); eval-when (compile load eval)
+
+
+(defmacro define-primitive-object ((name &rest options
+					 &key header lowtag
+					 &allow-other-keys)
+				   &rest slots)
+  (setf options (copy-list options))
+  (remf options :header)
+  (remf options :lowtag)
+  (let ((prim-obj
+	 (make-primitive-object :name name
+				:header header
+				:lowtag lowtag
+				:options options
+				:slots (mapcar #'(lambda (slot)
+						   (if (atom slot)
+						       (make-slot slot)
+						       (apply #'make-slot
+							      slot)))
+					       slots))))
+    (collect ((forms) (exports))
+      (let ((offset (if (primitive-object-header prim-obj) 1 0))
+	    (variable-length nil))
+	(dolist (slot (primitive-object-slots prim-obj))
+	  (when variable-length
+	    (error "~S is anything after a :rest-p t slot." slot))
+	  (let* ((rest-p (slot-rest-p slot))
+		 (offset-sym
+		  (intern (concatenate 'simple-string
+				       (string name)
+				       "-"
+				       (string (slot-name slot))
+				       (if rest-p "-OFFSET" "-SLOT")))))
+	    (forms `(defconstant ,offset-sym ,offset
+		      ,@(when (slot-docs slot) (list (slot-docs slot)))))
+	    (setf (slot-offset slot) offset)
+	    (exports offset-sym)
+	    (incf offset (slot-length slot))
+	    (when rest-p (setf variable-length t))))
+	(setf (primitive-object-variable-length prim-obj) variable-length)
+	(unless variable-length
+	  (let ((size (intern (concatenate 'simple-string
+					   (string name)
+					   "-SIZE"))))
+	    (forms `(defconstant ,size ,offset
+		      ,(format nil
+			       "Number of slots used by each ~S~
+			       ~@[~* including the header~]."
+			       name header)))
+	    (exports size)))
+	(setf (primitive-object-size prim-obj) offset))
+      `(eval-when (compile load eval)
+	 (setf *primitive-objects*
+	       (cons ',prim-obj
+		     (delete ',name *primitive-objects*
+			     :key #'primitive-object-name)))
+	 (export ',(exports))
+	 ,@(forms)))))
+
+(defmacro define-for-each-primitive-object ((var) &body body)
+  (let ((name (gensym)))
+    `(macrolet ((,name (,var) ,@body))
+       ,@(mapcar #'(lambda (x)
+		     `(,name ,x))
+		 *primitive-objects*))))
+
+
+;;;; The primitive objects themselves.
+
+
+(define-primitive-object (cons :lowtag list-pointer-type
+			       :alloc-trans cons)
+  (car :ref-vop car :ref-trans car
+       :setf-vop c::set-car :set-trans c::%rplaca
+       :init :arg)
+  (cdr :ref-vop cdr :ref-trans cdr
+       :setf-vop c::set-cdr :set-trans c::%rplacd
+       :init :arg))
+
+(define-primitive-object (bignum :lowtag other-pointer-type
+				 :header bignum-type
+				 :alloc-trans bignum::%allocate-bignum)
+  (digits :rest-p t :c-type "long"))
+
+(define-primitive-object (ratio :lowtag other-pointer-type
+				:header ratio-type
+				:alloc-vop c::make-ratio
+				:alloc-trans %make-ratio)
+  (numerator :ref-vop numerator :init :arg)
+  (denominator :ref-vop denominator :init :arg))
+
+(define-primitive-object (single-float :lowtag other-pointer-type
+				       :header single-float-type)
+  (value :c-type "float"))
+
+(define-primitive-object (double-float :lowtag other-pointer-type
+				       :header double-float-type)
+  (filler)
+  (value :c-type "double" :length 2))
+
+(define-primitive-object (complex :lowtag other-pointer-type
+				  :header complex-type
+				  :alloc-vop c::make-complex
+				  :alloc-trans %make-complex)
+  (real :ref-vop realpart :init :arg)
+  (imag :ref-vop imagpart :init :arg))
+
+(define-primitive-object (array :lowtag other-pointer-type
+				:header t)
+  (fill-pointer :type index
+		:ref-trans %array-fill-pointer
+		:ref-known (c::flushable c::foldable)
+		:set-trans (setf %array-fill-pointer)
+		:set-known (c::unsafe))
+  (fill-pointer-p :type (member t nil)
+		  :ref-trans %array-fill-pointer-p
+		  :ref-known (c::flushable c::foldable)
+		  :set-trans (setf %array-fill-pointer-p)
+		  :set-known (c::unsafe))
+  (elements :type index
+	    :ref-trans %array-available-elements
+	    :ref-known (c::flushable c::foldable)
+	    :set-trans (setf %array-available-elements)
+	    :set-known (c::unsafe))
+  (data :type array
+	:ref-trans %array-data-vector
+	:ref-known (c::flushable c::foldable)
+	:set-trans (setf %array-data-vector)
+	:set-known (c::unsafe))
+  (displacement :type (or index null)
+		:ref-trans %array-displacement
+		:ref-known (c::flushable c::foldable)
+		:set-trans (setf %array-displacement)
+		:set-known (c::unsafe))
+  (displaced-p :type (member t nil)
+	       :ref-trans %array-displaced-p
+	       :ref-known (c::flushable c::foldable)
+	       :set-trans (setf %array-displaced-p)
+	       :set-known (c::unsafe))
+  (dimensions :rest-p t))
+
+(define-primitive-object (vector :lowtag other-pointer-type :header t)
+  (length :ref-trans c::vector-length
+	  :type index
+	  :ref-known (c::flushable c::foldable))
+  (data :rest-p t :c-type "unsigned long"))
+
+(define-primitive-object (code :lowtag other-pointer-type :header t)
+  (code-size :ref-vop c::code-code-size)
+  (entry-points :ref-vop c::code-entry-points
+		:set-vop c::set-code-entry-points)
+  (debug-info :type t
+	      :ref-trans di::code-debug-info
+	      :ref-known (c::flushable)
+	      :set-vop c::set-code-debug-info)
+  (constants :rest-p t))
+
+(define-primitive-object (function-header :lowtag function-pointer-type
+					  :header function-header-type)
+  (self :ref-vop c::function-self :set-vop c::set-function-self)
+  (next :ref-vop c::function-next :set-vop c::set-function-next)
+  (name :ref-vop c::function-name
+	:ref-known (c::flushable)
+	:ref-trans %function-header-name
+	:set-vop c::set-function-name)
+  (arglist :ref-vop c::function-arglist
+	   :ref-known (c::flushable)
+	   :ref-trans lisp::%function-header-arglist
+	   :set-vop c::set-function-arglist)
+  (type :ref-vop c::function-type
+	:ref-known (c::flushable)
+	:ref-trans lisp::%function-header-type
+	:set-vop c::set-function-type)
+  (code :rest-p t :c-type "unsigned char"))
+
+(define-primitive-object (return-pc :lowtag other-pointer-type :header t)
+  (return-point :c-type "unsigned char" :rest-p t))
+
+(define-primitive-object (closure :lowtag function-pointer-type
+				  :header closure-header-type
+				  :alloc-vop c::make-closure)
+  (function :init :arg
+	    :ref-vop c::closure-function
+	    :ref-known (c::flushable)
+	    :ref-trans %closure-function)
+  (info :rest-p t :set-vop c::closure-init :ref-vop c::closure-ref))
+
+(define-primitive-object (value-cell :lowtag other-pointer-type
+				     :header value-cell-header-type
+				     :alloc-vop c::make-value-cell)
+  (value :set-vop c::value-cell-set
+	 :ref-vop c::value-cell-ref
+	 :init :arg))
+
+(define-primitive-object (symbol :lowtag other-pointer-type
+				 :header symbol-header-type)
+  (value :set-trans set
+	 :setf-vop set)
+  (function)
+  (raw-function-addr :c-type "char *")
+  (setf-function)
+  (plist :ref-trans symbol-plist
+	 :setf-vop c::set-symbol-plist
+	 :set-trans c::%sp-set-plist)
+  (name :ref-trans symbol-name)
+  (package :ref-trans symbol-package
+	   :setf-vop c::set-package))
+
+(define-primitive-object (sap :lowtag other-pointer-type
+			      :header sap-type)
+  (pointer :c-type "char *"))
+
+
+(define-primitive-object (weak-pointer :lowtag other-pointer-type
+				       :header weak-pointer-type
+				       :alloc-trans c::%make-weak-pointer)
+  (value :ref-trans c::%weak-pointer-value
+	 :ref-known (c::flushable)
+	 :set-trans (setf c::%weak-pointer-value)
+	 :set-known (c::unsafe)
+	 :init :arg)
+  (broken :ref-trans c::%weak-pointer-broken
+	  :ref-known (c::flushable)
+	  :set-trans (setf c::%weak-pointer-broken)
+	  :set-known (c::unsafe)
+	  :init :arg)
+  (next :c-type "struct weak_pointer *"))
+  
+
+;;; Other non-heap data blocks.
+
+(define-primitive-object (binding)
+  value
+  symbol)
+
+(define-primitive-object (unwind-block)
+  (current-uwp :c-type "struct unwind_block *")
+  (current-cont :c-type "lispobj *")
+  current-code
+  entry-pc)
+
+(define-primitive-object (catch-block)
+  (current-uwp :c-type "struct unwind_block *")
+  (current-cont :c-type "lispobj *")
+  current-code
+  entry-pc
+  tag
+  (previous-catch :c-type "struct catch_block *")
+  size)
+
diff --git a/compiler/generic/primtype.lisp b/compiler/generic/primtype.lisp
new file mode 100644
index 000000000..6cbceaa7c
--- /dev/null
+++ b/compiler/generic/primtype.lisp
@@ -0,0 +1,254 @@
+;;; -*- Package: C; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public
+;;; domain.  If you want to use this code or any part of CMU Common
+;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.1 1990/11/03 03:16:46 wlott Exp $
+;;;
+;;; This file contains the machine independent aspects of the object
+;;; representation and primitive types.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package "VM")
+
+
+;;;; Primitive Type Definitions
+
+;;; *Anything*
+;;; 
+(def-primitive-type t (descriptor-reg))
+(setf (backend-any-primitive-type *backend*) (primitive-type-or-lose 't))
+
+;;; Primitive integer types that fit in registers.
+;;;
+(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
+  :type (unsigned-byte 29))
+(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
+  :type (unsigned-byte 31))
+(def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
+  :type (unsigned-byte 32))
+(def-primitive-type fixnum (any-reg signed-reg)
+  :type (signed-byte 30))
+(def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
+  :type (signed-byte 32))
+
+(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
+
+(def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
+(def-primitive-type-alias unsigned-num (:or unsigned-byte-32
+					    unsigned-byte-31
+					    positive-fixnum))
+(def-primitive-type-alias signed-num (:or signed-byte-32
+					  fixnum
+					  unsigned-byte-31
+					  positive-fixnum))
+
+;;; Other primitive immediate types.
+(def-primitive-type base-character (base-character-reg any-reg))
+
+;;; Primitive pointer types.
+;;; 
+(def-primitive-type function (descriptor-reg))
+(def-primitive-type list (descriptor-reg))
+(def-primitive-type structure (descriptor-reg))
+
+;;; Primitive other-pointer number types.
+;;; 
+(def-primitive-type bignum (descriptor-reg))
+(def-primitive-type ratio (descriptor-reg))
+(def-primitive-type complex (descriptor-reg))
+(def-primitive-type single-float (single-reg descriptor-reg))
+(def-primitive-type double-float (double-reg descriptor-reg))
+
+;;; Primitive other-pointer array types.
+;;; 
+(def-primitive-type simple-string (descriptor-reg) :type simple-base-string)
+(def-primitive-type simple-bit-vector (descriptor-reg))
+(def-primitive-type simple-vector (descriptor-reg))
+(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
+  :type (simple-array (unsigned-byte 2) (*)))
+(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
+  :type (simple-array (unsigned-byte 4) (*)))
+(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
+  :type (simple-array (unsigned-byte 8) (*)))
+(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
+  :type (simple-array (unsigned-byte 16) (*)))
+(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
+  :type (simple-array (unsigned-byte 32) (*)))
+(def-primitive-type simple-array-single-float (descriptor-reg)
+  :type (simple-array single-float (*)))
+(def-primitive-type simple-array-double-float (descriptor-reg)
+  :type (simple-array double-float (*)))
+
+;;; Note: The complex array types are not inclueded, 'cause it is pointless to
+;;; restrict VOPs to them.
+
+;;; Other primitive other-pointer types.
+;;; 
+(def-primitive-type system-area-pointer (sap-reg descriptor-reg))
+(def-primitive-type weak-pointer (descriptor-reg))
+
+;;; Random primitive types that don't exist at the LISP level.
+;;; 
+(def-primitive-type random (non-descriptor-reg) :type nil)
+(def-primitive-type interior (interior-reg) :type nil)
+(def-primitive-type catch-block (catch-block) :type nil)
+
+
+
+
+;;;; Primitive-type-of and friends.
+
+;;; Primitive-Type-Of  --  Interface
+;;;
+;;;    Return the most restrictive primitive type that contains Object.
+;;;
+(def-vm-support-routine primitive-type-of (object)
+  (let ((type (ctype-of object)))
+    (cond ((not (member-type-p type)) (primitive-type type))
+	  ((equal (member-type-members type) '(nil))
+	   (primitive-type-or-lose 'list))
+	  (t
+	   *any-primitive-type*))))
+
+;;; 
+(defvar *simple-array-primitive-types*
+  '((base-character . simple-string)
+    (string-char . simple-string)
+    (bit . simple-bit-vector)
+    ((unsigned-byte 2) . simple-array-unsigned-byte-2)
+    ((unsigned-byte 4) . simple-array-unsigned-byte-4)
+    ((unsigned-byte 8) . simple-array-unsigned-byte-8)
+    ((unsigned-byte 16) . simple-array-unsigned-byte-16)
+    ((unsigned-byte 32) . simple-array-unsigned-byte-32)
+    (single-float . simple-array-single-float)
+    (double-float . simple-array-double-float)
+    (t . simple-vector))
+  "An a-list for mapping simple array element types to their
+  corresponding primitive types.")
+
+
+;;; Return the primitive type corresponding to a type descriptor
+;;; structure. The second value is true when the primitive type is
+;;; exactly equivalent to the argument Lisp type.
+;;;
+;;; In a bootstrapping situation, we should be careful to use the
+;;; correct values for the system parameters.
+;;;
+;;; We need an aux function because we need to use both def-vm-support-routine
+;;; and defun-cached.
+;;; 
+(def-vm-support-routine primitive-type (type)
+  (primitive-type-aux type))
+;;;
+(defun-cached (primitive-type-aux
+	       :hash-function (lambda (x)
+				(logand (cache-hash-eq x) #x1FF))
+	       :hash-bits 9
+	       :values 2
+	       :default (values nil :empty))
+	      ((type eq))
+  (declare (type ctype type))
+  (macrolet ((any () '(values *any-primitive-type* nil))
+	     (exactly (type) `(values (primitive-type-or-lose ',type) t))
+	     (part-of (type) `(values (primitive-type-or-lose ',type) nil)))
+    (etypecase type
+      (numeric-type
+       (let ((lo (numeric-type-low type))
+	     (hi (numeric-type-high type)))
+	 (case (numeric-type-complexp type)
+	   (:real
+	    (case (numeric-type-class type)
+	      (integer
+	       (cond ((and hi lo)
+		      (dolist (spec
+			       '((positive-fixnum 0 #.(1- (ash 1 29)))
+				 (unsigned-byte-31 0 #.(1- (ash 1 31)))
+				 (unsigned-byte-32 0 #.(1- (ash 1 32)))
+				 (fixnum #.(ash -1 29) #.(1- (ash 1 29)))
+				 (signed-byte-32 #.(ash -1 31)
+						 #.(1- (ash 1 31))))
+			       (if (or (< hi (ash -1 29))
+				       (> lo (1- (ash 1 29))))
+				   (part-of bignum)
+				   (any)))
+			(let ((type (car spec))
+			      (min (cadr spec))
+			      (max (caddr spec)))
+			  (when (<= min lo hi max)
+			    (return (values (primitive-type-or-lose type)
+					    (and (= lo min) (= hi max))))))))
+		     ((or (and hi (< hi most-negative-fixnum))
+			  (and lo (> lo most-positive-fixnum)))
+		      (part-of bignum))
+		     (t
+		      (any))))
+	      (float
+	       (let ((exact (and (null lo) (null hi))))
+		 (case (numeric-type-format type)
+		   ((short-float single-float)
+		    (values (primitive-type-or-lose 'single-float) exact))
+		   ((double-float long-float)
+		    (values (primitive-type-or-lose 'double-float) exact))
+		   (t
+		    (any)))))
+	      (t
+	       (any))))
+	   (:complex
+	    (part-of complex))
+	   (t
+	    (any)))))
+      (array-type
+       (if (array-type-complexp type)
+	   (any)
+	   (let* ((dims (array-type-dimensions type))
+		  (etype (array-type-specialized-element-type type))
+		  (type-spec (type-specifier etype))
+		  (ptype (cdr (assoc type-spec *simple-array-primitive-types*
+				     :test #'equal))))
+	     (if (and (consp dims) (null (rest dims)) ptype)
+		 (values (primitive-type-or-lose ptype) (eq (first dims) '*))
+		 (any)))))
+      (union-type
+       (if (type= type (specifier-type 'list))
+	   (exactly list)
+	   (let ((types (union-type-types type)))
+	     (multiple-value-bind (res exact)
+				  (primitive-type (first types))
+	       (dolist (type (rest types) (values res exact))
+		 (multiple-value-bind (ptype ptype-exact)
+				      (primitive-type type)
+		   (unless ptype-exact (setq exact nil))
+		   (unless (eq ptype res)
+		     (return (any)))))))))
+      (member-type
+       (let* ((members (member-type-members type))
+	      (res (primitive-type-of (first members))))
+	 (dolist (mem (rest members) (values res nil))
+	   (unless (eq (primitive-type-of mem) res)
+	     (return (values *any-primitive-type* nil))))))
+      (named-type
+       (case (named-type-name type)
+	 ((t bignum ratio complex function structure
+	     system-area-pointer weak-pointer)
+	  (values (primitive-type-or-lose (named-type-name type)) t))
+	 ((character base-character string-char)
+	  (exactly base-character))
+	 (standard-char
+	  (part-of base-character))
+	 (cons
+	  (part-of list))
+	 (t
+	  (any))))
+      (function-type
+       (exactly function))
+      (structure-type
+       (part-of structure))
+      (ctype
+       (any)))))
+
diff --git a/compiler/generic/utils.lisp b/compiler/generic/utils.lisp
new file mode 100644
index 000000000..f79aa30b7
--- /dev/null
+++ b/compiler/generic/utils.lisp
@@ -0,0 +1,57 @@
+;;; -*- Package: VM; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/utils.lisp,v 1.1 1990/11/03 03:17:32 wlott Exp $
+;;;
+;;; Utility functions needed by the back end to generate code.
+;;;
+;;; Written by William Lott.
+;;; 
+
+(in-package "VM")
+
+(export '(fixnum static-symbol-p static-symbol-offset offset-static-symbol))
+
+
+
+;;;; Handy routine for making fixnums:
+
+(defun fixnum (num)
+  "Make a fixnum out of NUM.  (i.e. shift by two bits if it will fit.)"
+  (if (<= #x-20000000 num #x1fffffff)
+      (ash num 2)
+      (error "~D is too big for a fixnum." num)))
+
+
+
+;;;; Routines for dealing with static symbols.
+
+(defun static-symbol-p (symbol)
+  (member symbol static-symbols))
+
+(defun static-symbol-offset (symbol)
+  "Returns the byte offset of the static symbol Symbol."
+  (let ((posn (position symbol static-symbols)))
+    (unless posn (error "~S is not a static symbol." symbol))
+    (+ (* posn (pad-data-block symbol-size))
+       (pad-data-block (1- symbol-size))
+       other-pointer-type
+       (- list-pointer-type))))
+
+(defun offset-static-symbol (offset)
+  "Given a byte offset, Offset, returns the appropriate static symbol."
+  (multiple-value-bind
+      (n rem)
+      (truncate (+ offset list-pointer-type (- other-pointer-type)
+		   (- (pad-data-block (1- symbol-size))))
+		(pad-data-block symbol-size))
+    (unless (and (zerop rem) (<= 0 n (1- (length static-symbols))))
+      (error "Byte offset, ~D, is not correct." offset))
+    (elt static-symbols n)))
+
-- 
GitLab