--- /dev/null
+/* -*-C-*-
+
+$Id: prgdbm.c,v 1.1 1996/04/23 20:36:48 cph Exp $
+
+Copyright (c) 1996 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Interface to the gdbm database library */
+
+#include "scheme.h"
+#include "prims.h"
+#include "os.h"
+#include <gdbm.h>
+\f
+/* Allocation Tables */
+
+struct allocation_table
+{
+ PTR * items;
+ int length;
+};
+
+static void
+DEFUN (allocation_table_initialize, (table), struct allocation_table * table)
+{
+ (table -> length) = 0;
+}
+
+static unsigned int
+DEFUN (allocate_table_index, (table, item),
+ struct allocation_table * table AND
+ PTR item)
+{
+ unsigned int length = (table -> length);
+ unsigned int new_length;
+ PTR * items = (table -> items);
+ PTR * new_items;
+ PTR * scan;
+ PTR * end;
+ if (length == 0)
+ {
+ new_length = 4;
+ new_items = (OS_malloc ((sizeof (PTR)) * new_length));
+ }
+ else
+ {
+ scan = items;
+ end = (scan + length);
+ while (scan < end)
+ if ((*scan++) == 0)
+ {
+ (*--scan) = item;
+ return (scan - items);
+ }
+ new_length = (length * 2);
+ new_items = (OS_realloc (items, ((sizeof (PTR)) * new_length)));
+ }
+ scan = (new_items + length);
+ end = (new_items + new_length);
+ (*scan++) = item;
+ while (scan < end)
+ (*scan++) = 0;
+ (table -> items) = new_items;
+ (table -> length) = new_length;
+ return (length);
+}
+
+static PTR
+DEFUN (allocation_item_arg, (arg, table),
+ unsigned int arg AND
+ struct allocation_table * table)
+{
+ unsigned int index = (arg_ulong_index_integer (arg, (table -> length)));
+ PTR item = ((table -> items) [index]);
+ if (item == 0)
+ error_bad_range_arg (arg);
+ return (item);
+}
+\f
+static struct allocation_table dbf_table;
+
+#define DBF_VAL(dbf) \
+ (ulong_to_integer (allocate_table_index ((&dbf_table), ((PTR) (dbf)))))
+
+#define DBF_ARG(arg) \
+ ((GDBM_FILE) (allocation_item_arg ((arg), (&dbf_table))))
+
+#define GDBM_ERROR_VAL() \
+ (char_pointer_to_string ((unsigned char *) (gdbm_strerror (gdbm_errno))))
+
+#define VOID_GDBM_CALL(expression) \
+ (((expression) == 0) ? SHARP_F : (GDBM_ERROR_VAL ()))
+
+static datum
+DEFUN (arg_datum, (arg), int arg)
+{
+ datum d;
+ CHECK_ARG (arg, STRING_P);
+ (d . dptr) = ((char *) (STRING_LOC ((ARG_REF (arg)), 0)));
+ (d . dsize) = (STRING_LENGTH (ARG_REF (arg)));
+ return (d);
+}
+
+static SCHEME_OBJECT
+DEFUN (datum_to_object, (d), datum d)
+{
+ if (d . dptr)
+ {
+ SCHEME_OBJECT result = (allocate_string (d . dsize));
+ CONST char * scan_d = (d . dptr);
+ CONST char * end_d = (scan_d + (d . dsize));
+ unsigned char * scan_result = (STRING_LOC (result, 0));
+ while (scan_d < end_d)
+ (*scan_result++) = ((unsigned char) (*scan_d++));
+ free (d . dptr);
+ return (result);
+ }
+ else
+ return (SHARP_F);
+}
+
+static void
+DEFUN (gdbm_fatal_error, (msg), char * msg)
+{
+ fprintf (stderr, "\ngdbm: %s\n", msg);
+ fflush (stderr);
+ error_external_return ();
+}
+\f
+DEFINE_PRIMITIVE ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0)
+{
+ static int initialization_done = 0;
+ PRIMITIVE_HEADER (4);
+ if (!initialization_done)
+ {
+ allocation_table_initialize (&dbf_table);
+ initialization_done = 1;
+ }
+ {
+ GDBM_FILE dbf = (gdbm_open ((STRING_ARG (1)),
+ (arg_integer (2)),
+ (arg_integer (3)),
+ (arg_integer (4)),
+ gdbm_fatal_error));
+ PRIMITIVE_RETURN ((dbf == 0) ? (GDBM_ERROR_VAL ()) : (DBF_VAL (dbf)));
+ }
+}
+
+DEFINE_PRIMITIVE ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ gdbm_close (DBF_ARG (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0)
+{
+ PRIMITIVE_HEADER (4);
+ {
+ int result = (gdbm_store ((DBF_ARG (1)),
+ (arg_datum (2)),
+ (arg_datum (3)),
+ (arg_integer (4))));
+ PRIMITIVE_RETURN
+ ((result < 0) ? (GDBM_ERROR_VAL ()) : (BOOLEAN_TO_OBJECT (!result)));
+ }
+}
+
+DEFINE_PRIMITIVE ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (datum_to_object (gdbm_fetch ((DBF_ARG (1)), (arg_datum (2)))));
+}
+
+DEFINE_PRIMITIVE ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT (gdbm_exists ((DBF_ARG (1)), (arg_datum (2)))));
+}
+\f
+DEFINE_PRIMITIVE ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (((gdbm_delete ((DBF_ARG (1)), (arg_datum (2)))) == 0)
+ ? SHARP_T
+ : (gdbm_errno == GDBM_ITEM_NOT_FOUND)
+ ? SHARP_F
+ : (GDBM_ERROR_VAL ()));
+}
+
+DEFINE_PRIMITIVE ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (datum_to_object (gdbm_firstkey (DBF_ARG (1))));
+}
+
+DEFINE_PRIMITIVE ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (datum_to_object (gdbm_nextkey ((DBF_ARG (1)), (arg_datum (2)))));
+}
+
+DEFINE_PRIMITIVE ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (VOID_GDBM_CALL (gdbm_reorganize (DBF_ARG (1))));
+}
+
+DEFINE_PRIMITIVE ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ gdbm_sync (DBF_ARG (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) gdbm_version));
+}
+
+DEFINE_PRIMITIVE ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ int value = (arg_integer (3));
+ PRIMITIVE_RETURN
+ (VOID_GDBM_CALL (gdbm_setopt ((DBF_ARG (1)),
+ (arg_integer (2)),
+ (&value),
+ (sizeof (int)))));
+ }
+}
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: gdbm.scm,v 1.1 1996/04/23 20:37:04 cph Exp $
+
+Copyright (c) 1996 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; gdbm Database Library Interface
+;;; package: (runtime gdbm)
+
+(declare (usual-integrations))
+\f
+(define (gdbm-available?)
+ (implemented-primitive-procedure? (ucode-primitive gdbm-open 4)))
+
+;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can
+;; create the database.
+(define GDBM_READER 0) ;A reader.
+(define GDBM_WRITER 1) ;A writer.
+(define GDBM_WRCREAT 2) ;A writer. Create the db if needed.
+(define GDBM_NEWDB 3) ;A writer. Always create a new db.
+(define GDBM_FAST 16) ;Write fast! => No fsyncs.
+
+(define (gdbm-open filename block-size flags mode)
+ (let ((filename (->namestring (merge-pathnames filename))))
+ (without-interrupts
+ (lambda ()
+ (let ((descriptor
+ (gdbm-error ((ucode-primitive gdbm-open 4)
+ filename block-size flags mode))))
+ (let ((gdbf (make-gdbf descriptor filename)))
+ (add-to-protection-list! gdbf-list gdbf descriptor)
+ gdbf))))))
+
+(define (gdbm-close gdbf)
+ (if (not (gdbf? gdbf))
+ (error:wrong-type-argument gdbf "gdbm handle" 'GDBM-CLOSE))
+ (let ((descriptor (gdbf-descriptor gdbf)))
+ (if descriptor
+ (without-interrupts
+ (lambda ()
+ ((ucode-primitive gdbm-close 1) descriptor)
+ (remove-from-protection-list! gdbf-list gdbf)
+ (set-gdbf-descriptor! gdbf #f))))))
+
+;; Parameters to gdbm_store for simple insertion or replacement in the
+;; case that the key is already in the database.
+(define GDBM_INSERT 0) ;Never replace old data with new.
+(define GDBM_REPLACE 1) ;Always replace old data with new.
+
+(define (gdbm-store gdbf key datum flags)
+ (gdbm-error
+ ((ucode-primitive gdbm-store 4) (guarantee-gdbf gdbf 'GDBM-STORE)
+ key datum flags)))
+
+(define (gdbm-fetch gdbf key)
+ ((ucode-primitive gdbm-fetch 2) (guarantee-gdbf gdbf 'GDBM-FETCH) key))
+
+(define (gdbm-exists? gdbf key)
+ ((ucode-primitive gdbm-exists 2) (guarantee-gdbf gdbf 'GDBM-EXISTS?) key))
+
+(define (gdbm-delete gdbf key)
+ (gdbm-error
+ ((ucode-primitive gdbm-delete 2) (guarantee-gdbf gdbf 'GDBM-DELETE) key)))
+
+(define (gdbm-firstkey gdbf)
+ ((ucode-primitive gdbm-firstkey 1) (guarantee-gdbf gdbf 'GDBM-FIRSTKEY)))
+
+(define (gdbm-nextkey gdbf key)
+ ((ucode-primitive gdbm-nextkey 2) (guarantee-gdbf gdbf 'GDBM-NEXTKEY) key))
+
+(define (gdbm-reorganize gdbf)
+ (gdbm-error
+ ((ucode-primitive gdbm-reorganize 1)
+ (guarantee-gdbf gdbf 'GDBM-REORGANIZE))))
+
+(define (gdbm-sync gdbf)
+ ((ucode-primitive gdbm-sync 1) (guarantee-gdbf gdbf 'GDBM-SYNC)))
+
+(define (gdbm-version)
+ ((ucode-primitive gdbm-version 0)))
+
+;; Parameters to gdbm_setopt, specifing the type of operation to perform.
+(define GDBM_CACHESIZE 1) ;Set the cache size.
+(define GDBM_FASTMODE 2) ;Toggle fast mode.
+
+(define (gdbm-setopt gdbf opt val)
+ (gdbm-error
+ ((ucode-primitive gdbm-setopt 3) (guarantee-gdbf gdbf 'GDBM-SETOPT)
+ opt val)))
+
+(define-structure (gdbf
+ (print-procedure (standard-unparser-method 'GDBF
+ (lambda (gdbf port)
+ (write-char #\space port)
+ (write (gdbf-filename gdbf) port)))))
+ descriptor
+ (filename #f read-only #t))
+
+(define (guarantee-gdbf gdbf procedure)
+ (if (gdbf? gdbf)
+ (or (gdbf-descriptor gdbf) (error:bad-range-argument gdbf procedure))
+ (error:wrong-type-argument gdbf "gdbm handle" procedure)))
+
+(define (gdbm-error object)
+ (if (string? object) (error "gdbm error:" object))
+ object)
+
+(define gdbf-list)
+(define (initialize-package!)
+ (set! gdbf-list (make-protection-list))
+ (add-gc-daemon!
+ (lambda ()
+ (clean-lost-protected-objects gdbf-list (ucode-primitive gdbm-close 1))))
+ (add-event-receiver! event:after-restore
+ (lambda () (drop-all-protected-objects gdbf-list))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: gencache.scm,v 1.1 1996/04/23 20:37:15 cph Exp $
+;;;
+;;; Copyright (c) 1993-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Method Caches for Generic Dispatch
+
+;;; From "Efficient Method Dispatch in PCL", Gregor Kiczales and Luis
+;;; Rodriguez, Proceedings of the 1990 ACM Conference on Lisp and
+;;; Functional Programming. Parts of this code are based on the
+;;; September 16, 1992 PCL implementation.
+
+(declare (usual-integrations)
+ (integrate-external "gentag"))
+\f
+(define-structure (cache (constructor %make-cache))
+ (tag-index 0)
+ (mask 0 read-only #t)
+ (limit 0 read-only #t)
+ (n-tags 0 read-only #t)
+ (tags '#() read-only #t)
+ (values '#() read-only #t)
+ (overflow '()))
+
+(define (new-cache n-tags)
+ (make-cache dispatch-tag-index-start n-tags 4))
+
+(define (make-cache tag-index n-tags length)
+ ;; LENGTH is assumed to be a power of two.
+ (%make-cache tag-index
+ (fix:- length 1)
+ (cond ((fix:<= length 4) 1)
+ ((fix:<= length 16) 4)
+ (else 6))
+ n-tags
+ (make-vector length (make-list n-tags #f))
+ (make-vector length #f)
+ '()))
+
+(define-integrable (cache-length cache)
+ (vector-length (cache-tags cache)))
+
+(define-integrable (cache-line-tags cache line)
+ (vector-ref (cache-tags cache) line))
+
+(define-integrable (set-cache-line-tags! cache line tags)
+ (vector-set! (cache-tags cache) line tags))
+
+(define-integrable (cache-line-value cache line)
+ (vector-ref (cache-values cache) line))
+
+(define-integrable (set-cache-line-value! cache line value)
+ (vector-set! (cache-values cache) line value))
+
+(define-integrable (cache-next-line cache line)
+ (if (fix:= (fix:+ line 1) (cache-length cache))
+ 0
+ (fix:+ line 1)))
+
+(define-integrable (cache-line-separation cache line line*)
+ (let ((n (fix:- line* line)))
+ (if (fix:< n 0)
+ (fix:+ n (cache-length cache))
+ n)))
+\f
+(define (probe-cache cache tags)
+ (let ((line (compute-primary-cache-line cache tags)))
+ (and line
+ (let ((limit (cache-limit cache)))
+ (letrec
+ ((search-lines
+ (lambda (line i)
+ (cond ((match (cache-line-tags cache line))
+ (cache-line-value cache line))
+ ((fix:= i limit)
+ (search-overflow (cache-overflow cache)))
+ (else
+ (search-lines (cache-next-line cache line)
+ (fix:+ i 1))))))
+ (search-overflow
+ (lambda (overflow)
+ (and (not (null? overflow))
+ (if (match (caar overflow))
+ (cdar overflow)
+ (search-overflow (cdr overflow))))))
+ (match
+ (lambda (tags*)
+ (let loop ((w1 tags*) (w2 tags))
+ (and (eq? (system-pair-car w1) (system-pair-car w2))
+ (or (null? (system-pair-cdr w1))
+ (loop (system-pair-cdr w1)
+ (system-pair-cdr w2))))))))
+ (search-lines line 0))))))
+
+(define (compute-primary-cache-line cache tags)
+ (let ((index (cache-tag-index cache))
+ (mask (cache-mask cache)))
+ (let loop ((tags tags) (line 0))
+ (cond ((null? tags)
+ line)
+ ((not (system-pair-car tags))
+ #f)
+ (else
+ (loop (system-pair-cdr tags)
+ (fix:and (fix:+ line
+ (dispatch-tag-ref (system-pair-car tags)
+ index))
+ mask)))))))
+
+(define (cache-entry-reusable? tags tags*)
+ ;; True iff TAGS is (1) empty, (2) contains a tag that is invalid,
+ ;; or (3) has the same tags as TAGS*.
+ (or (not tags)
+ (let loop ((tags tags) (tags* tags*))
+ (or (null? tags)
+ (not (system-pair-car tags))
+ (and (eq? (system-pair-car tags) (system-pair-car tags*))
+ (loop (system-pair-cdr tags) (system-pair-cdr tags*)))))))
+
+(define (cache-count cache)
+ (let ((length (cache-length cache)))
+ (do ((line 0 (fix:+ line 1))
+ (count 0
+ (if (let ((tags (cache-line-tags cache line)))
+ (and tags
+ (let loop ((tags tags))
+ (or (null? tags)
+ (and (system-pair-car tags)
+ (loop (system-pair-cdr tags)))))))
+ (fix:+ count 1)
+ count)))
+ ((fix:= line length) count))))
+\f
+(declare (integrate-operator probe-cache-1))
+(define (probe-cache-1 cache w1)
+ (let ((line
+ (fix:and (dispatch-tag-ref w1 (cache-tag-index cache))
+ (cache-mask cache)))
+ (match
+ (lambda (tags)
+ (declare (integrate tags))
+ (eq? w1 (system-pair-car tags)))))
+ (declare (integrate line))
+ (declare (integrate-operator match))
+ (if (match (cache-line-tags cache line))
+ (cache-line-value cache line)
+ (let ((limit (cache-limit cache)))
+ (let search-lines ((line (cache-next-line cache line)) (i 0))
+ (cond ((fix:= i limit)
+ (let search-overflow ((entries (cache-overflow cache)))
+ (and (not (null? entries))
+ (if (match (caar entries))
+ (cdar entries)
+ (search-overflow (cdr entries))))))
+ ((and (cache-line-tags cache line)
+ (match (cache-line-tags cache line)))
+ (cache-line-value cache line))
+ (else
+ (search-lines (cache-next-line cache line)
+ (fix:+ i 1)))))))))
+
+(declare (integrate-operator probe-cache-2))
+(define (probe-cache-2 cache w1 w2)
+ (let ((line
+ (fix:and (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache))
+ (dispatch-tag-ref w2 (cache-tag-index cache)))
+ (cache-mask cache)))
+ (match
+ (lambda (tags)
+ (declare (integrate tags))
+ (and (eq? w1 (system-pair-car tags))
+ (eq? w2 (system-pair-car (system-pair-cdr tags)))))))
+ (declare (integrate line))
+ (declare (integrate-operator match))
+ (if (and (cache-line-tags cache line)
+ (match (cache-line-tags cache line)))
+ (cache-line-value cache line)
+ (let ((limit (cache-limit cache)))
+ (let search-lines ((line (cache-next-line cache line)) (i 0))
+ (cond ((fix:= i limit)
+ (let search-overflow ((entries (cache-overflow cache)))
+ (and (not (null? entries))
+ (if (match (caar entries))
+ (cdar entries)
+ (search-overflow (cdr entries))))))
+ ((and (cache-line-tags cache line)
+ (match (cache-line-tags cache line)))
+ (cache-line-value cache line))
+ (else
+ (search-lines (cache-next-line cache line)
+ (fix:+ i 1)))))))))
+\f
+(declare (integrate-operator probe-cache-3))
+(define (probe-cache-3 cache w1 w2 w3)
+ (let ((line
+ (fix:and
+ (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache))
+ (fix:+ (dispatch-tag-ref w2 (cache-tag-index cache))
+ (dispatch-tag-ref w3 (cache-tag-index cache))))
+ (cache-mask cache)))
+ (match
+ (lambda (tags)
+ (declare (integrate tags))
+ (and (eq? w1 (system-pair-car tags))
+ (eq? w2 (system-pair-car (system-pair-cdr tags)))
+ (eq? w3 (system-pair-car
+ (system-pair-cdr (system-pair-cdr tags))))))))
+ (declare (integrate line))
+ (declare (integrate-operator match))
+ (if (match (cache-line-tags cache line))
+ (cache-line-value cache line)
+ (let ((limit (cache-limit cache)))
+ (let search-lines ((line (cache-next-line cache line)) (i 0))
+ (cond ((fix:= i limit)
+ (let search-overflow ((entries (cache-overflow cache)))
+ (and (not (null? entries))
+ (if (match (caar entries))
+ (cdar entries)
+ (search-overflow (cdr entries))))))
+ ((and (cache-line-tags cache line)
+ (match (cache-line-tags cache line)))
+ (cache-line-value cache line))
+ (else
+ (search-lines (cache-next-line cache line)
+ (fix:+ i 1)))))))))
+
+(declare (integrate-operator probe-cache-4))
+(define (probe-cache-4 cache w1 w2 w3 w4)
+ (let ((line
+ (fix:and
+ (fix:+ (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache))
+ (dispatch-tag-ref w2 (cache-tag-index cache)))
+ (fix:+ (dispatch-tag-ref w3 (cache-tag-index cache))
+ (dispatch-tag-ref w4 (cache-tag-index cache))))
+ (cache-mask cache)))
+ (match
+ (lambda (tags)
+ (declare (integrate tags))
+ (and (eq? w1 (system-pair-car tags))
+ (eq? w2 (system-pair-car (system-pair-cdr tags)))
+ (eq? w3 (system-pair-car
+ (system-pair-cdr (system-pair-cdr tags))))
+ (eq? w4 (system-pair-car
+ (system-pair-cdr
+ (system-pair-cdr (system-pair-cdr tags)))))))))
+ (declare (integrate line))
+ (declare (integrate-operator match))
+ (if (match (cache-line-tags cache line))
+ (cache-line-value cache line)
+ (let ((limit (cache-limit cache)))
+ (let search-lines ((line (cache-next-line cache line)) (i 0))
+ (cond ((fix:= i limit)
+ (let search-overflow ((entries (cache-overflow cache)))
+ (and (not (null? entries))
+ (if (match (caar entries))
+ (cdar entries)
+ (search-overflow (cdr entries))))))
+ ((and (cache-line-tags cache line)
+ (match (cache-line-tags cache line)))
+ (cache-line-value cache line))
+ (else
+ (search-lines (cache-next-line cache line)
+ (fix:+ i 1)))))))))
+\f
+(define (fill-cache cache tags value)
+ ;; TAGS must be converted to a weak list since it will be stored in
+ ;; the cache, and we don't want the cache to prevent the tags from
+ ;; being GCed.
+ (let ((tags (list->weak-list tags)))
+ (or (fill-cache-if-possible cache tags value)
+ (and (< (cache-count cache) (* (cache-length cache) .8))
+ (adjust-cache cache tags value))
+ (expand-cache cache tags value))))
+
+(define (fill-cache-if-possible cache tags value)
+ (let ((primary (compute-primary-cache-line cache tags)))
+ (if primary
+ (let ((free (find-free-cache-line cache primary tags)))
+ (and free
+ (begin
+ (set-cache-line-tags! cache free tags)
+ (set-cache-line-value! cache free value)
+ cache)))
+ ;; TAGS contains an invalid tag. Do nothing and return CACHE
+ ;; because the fill is no longer needed. While other logic
+ ;; tries to eliminate this case, it can still happen when one
+ ;; of the tags is GCed during complex cache operations.
+ cache)))
+
+(define (adjust-cache cache tags value)
+ ;; Try to rehash the cache. If that fails, try rehashing with
+ ;; different tag indexes. Fail only when all of the tag indexes
+ ;; have been tried and none has worked.
+ (let ((length (cache-length cache)))
+ (let ((new-cache
+ (make-cache (cache-tag-index cache)
+ (cache-n-tags cache)
+ length)))
+ (letrec
+ ((fill-lines
+ (lambda (line)
+ (cond ((fix:= line length)
+ (fill-overflow (cache-overflow cache)))
+ ((try-entry (cache-line-tags cache line)
+ (cache-line-value cache line))
+ (fill-lines (fix:+ line 1)))
+ (else
+ (try-next-tag-index)))))
+ (fill-overflow
+ (lambda (entries)
+ (cond ((null? entries)
+ (or (fill-cache-if-possible new-cache tags value)
+ (try-next-tag-index)))
+ ((try-entry (caar entries) (cdar entries))
+ (fill-overflow (cdr entries)))
+ (else
+ (try-next-tag-index)))))
+ (try-entry
+ (lambda (tags* value)
+ (or (cache-entry-reusable? tags* tags)
+ (fill-cache-if-possible new-cache tags* value))))
+ (try-next-tag-index
+ (lambda ()
+ (let ((index
+ (next-dispatch-tag-index (cache-tag-index new-cache))))
+ (and index
+ (begin
+ (set-cache-tag-index! new-cache index)
+ (fill-lines 0)))))))
+ (fill-lines 0)))))
+\f
+(define (expand-cache cache tags value)
+ ;; Create a new cache that is twice the length of CACHE, rehash the
+ ;; contents of CACHE into the new cache, and make the new entry.
+ ;; Permits overflows to occur in the new cache.
+ (let ((length (cache-length cache)))
+ (letrec
+ ((fill-lines
+ (lambda (new-cache line)
+ (if (fix:= line length)
+ (fill-overflow new-cache (cache-overflow cache))
+ (fill-lines (maybe-do-fill new-cache
+ (cache-line-tags cache line)
+ (cache-line-value cache line))
+ (fix:+ line 1)))))
+ (fill-overflow
+ (lambda (new-cache overflow)
+ (if (null? overflow)
+ (do-fill new-cache tags value)
+ (fill-overflow (maybe-do-fill new-cache
+ (caar overflow)
+ (cdar overflow))
+ (cdr overflow)))))
+ (maybe-do-fill
+ (lambda (cache tags* value)
+ (if (cache-entry-reusable? tags* tags)
+ cache
+ (do-fill cache tags* value))))
+ (do-fill
+ (lambda (cache tags value)
+ (let ((primary (compute-primary-cache-line cache tags)))
+ (if primary
+ (let ((free (find-free-cache-line cache primary tags)))
+ (if free
+ (begin
+ (set-cache-line-tags! cache free tags)
+ (set-cache-line-value! cache free value)
+ cache)
+ (or (adjust-cache cache tags value)
+ (begin
+ (set-cache-overflow!
+ cache
+ (cons (cons (cache-line-tags cache primary)
+ (cache-line-value cache primary))
+ (cache-overflow cache)))
+ (set-cache-line-tags! cache primary tags)
+ (set-cache-line-value! cache primary value)
+ cache))))
+ cache)))))
+ (fill-lines (make-cache (cache-tag-index cache)
+ (cache-n-tags cache)
+ (fix:+ length length))
+ 0))))
+\f
+(define (find-free-cache-line cache primary tags)
+ ;; This procedure searches CACHE for a free line to hold an entry
+ ;; with the given PRIMARY cache number and TAGS. Since the entry
+ ;; can only be stored within (CACHE-LIMIT CACHE) lines of PRIMARY,
+ ;; we either have to find a free line within that limit, or we have
+ ;; to find a line with a larger primary which can be displaced to
+ ;; another free line within *its* limit.
+ (if (cache-entry-reusable? (cache-line-tags cache primary) tags)
+ primary
+ (let ((limit (cache-limit cache)))
+ ;; Find a line for an entry whose primary cache number is P.
+ ;; LINES is the sequence of entries that is waiting to be
+ ;; displaced into the line if we find it.
+ (let pri-loop
+ ((line (cache-next-line cache primary))
+ (p primary)
+ (tags tags)
+ (lines '()))
+ (let sec-loop
+ ((line line)
+ (nsep (cache-line-separation cache p line)))
+ (cond ((fix:= line primary)
+ ;; We've scanned through the entire cache without
+ ;; finding a usable line.
+ #f)
+ ((let ((tags* (cache-line-tags cache line)))
+ (and (not (cache-entry-reusable? tags* tags))
+ (compute-primary-cache-line cache tags*)))
+ =>
+ (lambda (lp)
+ (let ((osep (cache-line-separation cache lp line)))
+ (cond ((fix:>= osep limit)
+ ;; This line contains an entry that is
+ ;; displaced to the limit. [**** For
+ ;; some reason I don't understand, this
+ ;; terminates the search.]
+ #f)
+ ((or (fix:> nsep osep)
+ (and (fix:= nsep osep)
+ (= 0 (random 2))))
+ ;; The entry we're trying to place is
+ ;; further from its primary than the
+ ;; entry currently stored in this line.
+ ;; So now let's look for somewhere to
+ ;; displace the entry in this line.
+ (pri-loop (cache-next-line cache line)
+ lp
+ (cache-line-tags cache line)
+ (cons line lines)))
+ (else
+ (sec-loop (cache-next-line cache line)
+ (fix:+ nsep 1)))))))
+ (else
+ ;; Found a free line. First perform all of the
+ ;; entry displacements, then return the subsequent
+ ;; free line.
+ (without-interrupts
+ (lambda ()
+ (let loop ((free-line line) (lines lines))
+ (if (null? lines)
+ (begin
+ (set-cache-line-tags! cache free-line #f)
+ (set-cache-line-value! cache free-line #f)
+ free-line)
+ (let ((line (car lines)))
+ (set-cache-line-tags!
+ cache
+ free-line
+ (cache-line-tags cache line))
+ (set-cache-line-value!
+ cache
+ free-line
+ (cache-line-value cache line))
+ (loop line (cdr lines))))))))))))))
+\f
+(define (purge-cache-entries cache predicate)
+ (if (there-exists-a-cache-entry? cache predicate)
+ ;; Must rebuild cache since deletions are near-impossible.
+ (let loop
+ ((cache (new-cache (cache-n-tags cache)))
+ (alist (cache->alist cache)))
+ (if (null? alist)
+ cache
+ (loop (if (predicate (caar alist))
+ cache
+ (fill-cache cache (caar alist) (cdar alist)))
+ (cdr alist))))
+ cache))
+
+(define (there-exists-a-cache-entry? cache predicate)
+ (let ((length (cache-length cache)))
+ (let loop ((line 0))
+ (and (not (fix:= line length))
+ (let ((tags (cache-line-tags cache line)))
+ (if (or (not tags)
+ (not (system-pair-car tags)))
+ (loop (fix:+ line 1))
+ (or (predicate (weak-list->list tags))
+ (loop (fix:+ line 1)))))))))
+
+(define (cache->alist cache)
+ (let ((length (cache-length cache)))
+ (do ((line 0 (fix:+ line 1))
+ (alist '()
+ (let ((tags (cache-line-tags cache line)))
+ (if (or (not tags)
+ (not (system-pair-car tags)))
+ alist
+ (cons (cons (weak-list->list tags)
+ (cache-line-value cache line))
+ alist)))))
+ ((fix:= line length) alist))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: geneqht.scm,v 1.1 1996/04/23 20:37:27 cph Exp $
+
+Copyright (c) 1990-96 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; EQ?-Hash Tables for Generic Procedures
+
+(declare (usual-integrations))
+\f
+(define (make-eqht)
+ (let ((table (%make-eqht)))
+ (reset-table! table)
+ (record-address-hash-table! table)
+ table))
+
+(define (eqht/get table key default)
+ (let ((entries
+ (vector-ref (table-buckets table) (compute-key-hash table key))))
+ (let loop ((entries entries))
+ (cond ((null? entries)
+ default)
+ ((eq? (system-pair-car (car entries)) key)
+ (system-pair-cdr (car entries)))
+ (else
+ (loop (cdr entries)))))))
+
+(define (eqht/put! table key datum)
+ (let ((buckets (table-buckets table))
+ (hash (compute-key-hash table key)))
+ (let loop ((entries (vector-ref buckets hash)))
+ (cond ((null? entries)
+ (without-interrupts
+ (lambda ()
+ (vector-set! buckets
+ hash
+ (cons (weak-cons key datum)
+ (vector-ref buckets hash)))
+ (if (> (let ((count (fix:+ (table-count table) 1)))
+ (set-table-count! table count)
+ count)
+ (table-grow-size table))
+ (grow-table! table)))))
+ ((eq? (system-pair-car (car entries)) key)
+ (system-pair-set-cdr! (car entries) datum))
+ (else
+ (loop (cdr entries)))))))
+
+(define (eqht/for-each table procedure)
+ (for-each-vector-element (table-buckets table)
+ (lambda (entries)
+ (for-each (lambda (entry)
+ (if (system-pair-car entry)
+ (procedure (system-pair-car entry)
+ (system-pair-cdr entry))))
+ entries))))
+\f
+;;;; Address Hashing
+
+(define (compute-key-hash table key)
+ (let loop ()
+ (let ((hash (eq-hash-mod key (vector-length (table-buckets table)))))
+ (if (not (table-needs-rehash? table))
+ hash
+ (begin
+ (without-interrupts (lambda () (rehash-table! table)))
+ (loop))))))
+
+(define-integrable (eq-hash-mod key modulus)
+ (fix:remainder (let ((n
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type positive-fixnum)
+ key)))
+ (if (fix:< n 0)
+ (fix:not n)
+ n))
+ modulus))
+
+(define (record-address-hash-table! table)
+ (set! address-hash-tables (weak-cons table address-hash-tables))
+ unspecific)
+
+(define (mark-address-hash-tables!)
+ (let loop ((previous #f) (tables address-hash-tables))
+ (cond ((null? tables)
+ unspecific)
+ ((system-pair-car tables)
+ (set-table-needs-rehash?! (system-pair-car tables) #t)
+ (loop tables (system-pair-cdr tables)))
+ (else
+ (if previous
+ (system-pair-set-cdr! previous (system-pair-cdr tables))
+ (set! address-hash-tables (system-pair-cdr tables)))
+ (loop previous (system-pair-cdr tables))))))
+
+(define address-hash-tables)
+
+(define (initialize-address-hashing!)
+ (set! address-hash-tables '())
+ (add-primitive-gc-daemon! mark-address-hash-tables!))
+\f
+;;;; Resizing
+
+(define (grow-table! table)
+ (let loop ((size (table-grow-size table)))
+ (if (> (table-count table) size)
+ (loop (let ((size* (round->exact (* size 2.))))
+ (if (> size* size)
+ size*
+ (+ size 1))))
+ (new-size! table size))))
+
+(define (shrink-table! table)
+ (let loop ((size (table-grow-size table)))
+ (cond ((<= size minimum-size)
+ (new-size! table minimum-size))
+ ((< (table-count table) (compute-shrink-size size))
+ (loop (decrement-size size)))
+ (else
+ (new-size! table size)))))
+
+(define (new-size! table size)
+ (set-table-grow-size! table size)
+ (let ((old-buckets (table-buckets table)))
+ (reset-table! table)
+ (rehash-table-from-old-buckets! table old-buckets)))
+
+(define (reset-table! table)
+ (set-table-shrink-size! table (compute-shrink-size (table-grow-size table)))
+ (let ((primes
+ (let ((size (round->exact (table-grow-size table))))
+ (let loop
+ ((primes
+ (if (< size (stream-car (table-primes table)))
+ prime-numbers-stream
+ (table-primes table))))
+ (if (<= size (stream-car primes))
+ primes
+ (loop (stream-cdr primes)))))))
+ (set-table-primes! table primes)
+ (set-table-buckets! table (make-vector (stream-car primes) '()))))
+
+(define (compute-shrink-size size)
+ (if (<= size minimum-size)
+ 0
+ (max 0 (decrement-size (decrement-size size)))))
+
+(define (decrement-size size)
+ (let ((size* (round->exact (/ size 2.))))
+ (if (< size* size)
+ size*
+ (- size 1))))
+\f
+;;;; Rehashing
+
+(define (rehash-table-from-old-buckets! table buckets)
+ (let ((n-buckets (vector-length buckets)))
+ (set-table-needs-rehash?! table #f)
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n-buckets))
+ (let ((entries (vector-ref buckets i)))
+ (if (not (null? entries))
+ (rehash-table-entries! table entries)))))
+ (maybe-shrink-table! table))
+
+(define (rehash-table-entries! table entries)
+ (let ((buckets (table-buckets table)))
+ (let ((n-buckets (vector-length buckets)))
+ (let loop ((entries entries))
+ (if (not (null? entries))
+ (let ((rest (cdr entries)))
+ (if (system-pair-car (car entries))
+ (let ((hash
+ (eq-hash-mod (system-pair-car (car entries))
+ n-buckets)))
+ (set-cdr! entries (vector-ref buckets hash))
+ (vector-set! buckets hash entries))
+ (set-table-count! table (fix:- (table-count table) 1)))
+ (loop rest)))))))
+
+(define (maybe-shrink-table! table)
+ ;; Since the rehashing also deletes invalid entries, the count
+ ;; might have been reduced. So check to see if it's necessary to
+ ;; shrink the table even further.
+ (if (< (table-count table) (table-shrink-size table))
+ (shrink-table! table)))
+
+(define (rehash-table! table)
+ (let ((entries (extract-table-entries! table)))
+ (set-table-needs-rehash?! table #f)
+ (rehash-table-entries! table entries))
+ (maybe-shrink-table! table))
+
+(define (extract-table-entries! table)
+ (let ((buckets (table-buckets table)))
+ (let ((n-buckets (vector-length buckets)))
+ (let ((entries '()))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n-buckets))
+ (let ((bucket (vector-ref buckets i)))
+ (if (not (null? bucket))
+ (begin
+ (let loop ((bucket bucket))
+ (if (null? (cdr bucket))
+ (set-cdr! bucket entries)
+ (loop (cdr bucket))))
+ (set! entries bucket)
+ (vector-set! buckets i '())))))
+ entries))))
+\f
+;;;; Miscellaneous
+
+(define-structure (eqht (constructor %make-eqht ()) (conc-name table-))
+ (count 0)
+ (grow-size minimum-size)
+ (shrink-size 0)
+ buckets
+ (primes prime-numbers-stream)
+ (needs-rehash? #f))
+
+(define-integrable minimum-size 4)
+
+(define-integrable (without-interrupts thunk)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (thunk)
+ (set-interrupt-enables! interrupt-mask)
+ unspecific))
+
+(define-integrable (weak-cons car cdr)
+ (system-pair-cons (ucode-type weak-cons) car cdr))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: generic.scm,v 1.1 1996/04/23 20:37:35 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Generic Procedures
+
+(declare (usual-integrations)
+ (integrate-external "gentag" "gencache"))
+\f
+;;;; Generic Procedures
+
+(define (make-generic-procedure arity #!optional name tag generator)
+ (let ((name (if (default-object? name) #f name))
+ (tag (if (default-object? tag) #f tag))
+ (generator (if (default-object? generator) #f generator)))
+ (if (and name (not (symbol? name)))
+ (error:wrong-type-argument name "symbol" 'MAKE-GENERIC-PROCEDURE))
+ (if tag (guarantee-dispatch-tag tag 'MAKE-GENERIC-PROCEDURE))
+ (if (not (or (and (exact-integer? arity)
+ (> arity 0))
+ (and (pair? arity)
+ (exact-integer? (car arity))
+ (> (car arity) 0)
+ (or (not (cdr arity))
+ (and (exact-integer? (cdr arity))
+ (>= (cdr arity) (car arity)))))))
+ (error:wrong-type-argument arity "arity"
+ 'MAKE-GENERIC-PROCEDURE))
+ (guarantee-generator generator 'MAKE-GENERIC-PROCEDURE)
+ (let ((record
+ (make-generic-record (or tag standard-generic-procedure-tag)
+ (if (and (pair? arity)
+ (eqv? (car arity) (cdr arity)))
+ (car arity)
+ arity)
+ generator
+ name)))
+ (let ((generic (compute-apply-generic record)))
+ (set-generic-record/procedure! record generic)
+ (eqht/put! generic-procedure-records generic record)
+ generic))))
+
+(define-structure (generic-record
+ (conc-name generic-record/)
+ (constructor make-generic-record
+ (tag arity generator name)))
+ (tag #f read-only #t)
+ (arity #f read-only #t)
+ (generator #f)
+ (name #f read-only #t)
+ (cache (new-cache (if (pair? arity) (car arity) arity)))
+ procedure)
+
+(define (generic-record/min-arity record)
+ (arity-min (generic-record/arity record)))
+
+(define (generic-record/max-arity record)
+ (arity-max (generic-record/arity record)))
+
+(define (arity-min arity)
+ (if (pair? arity) (car arity) arity))
+
+(define (arity-max arity)
+ (if (pair? arity) (cdr arity) arity))
+
+(define (generic-procedure? object)
+ (if (eqht/get generic-procedure-records object #f) #t #f))
+
+(define (generic-procedure-arity generic)
+ (generic-record/arity
+ (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-ARITY)))
+
+(define (generic-procedure-name generic)
+ (generic-record/name
+ (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-NAME)))
+\f
+(define (generic-procedure-generator generic)
+ (generic-record/generator
+ (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-GENERATOR)))
+
+(define (set-generic-procedure-generator! generic generator)
+ (let ((record
+ (guarantee-generic-procedure generic
+ 'SET-GENERIC-PROCEDURE-GENERATOR!)))
+ (guarantee-generator generator 'SET-GENERIC-PROCEDURE-GENERATOR!)
+ (without-interrupts
+ (lambda ()
+ (set-generic-record/generator! record generator)
+ (%reset-generic-procedure-cache! record)))))
+
+(define (purge-generic-procedure-cache generic #!optional filter)
+ (let ((operator
+ (if (or (default-object? filter)
+ (eq? 'ALL-ENTRIES filter))
+ (lambda (generic record)
+ generic
+ (%reset-generic-procedure-cache! record))
+ (lambda (generic record)
+ (%purge-generic-procedure-cache! generic record filter)))))
+ (if (eq? 'ALL-PROCEDURES generic)
+ (eqht/for-each generic-procedure-records operator)
+ (operator
+ generic
+ (guarantee-generic-procedure generic
+ 'PURGE-GENERIC-PROCEDURE-CACHE)))))
+
+(define (%reset-generic-procedure-cache! record)
+ (set-generic-record/cache! record
+ (new-cache (generic-record/min-arity record))))
+
+(define (%purge-generic-procedure-cache! generic record filter)
+ ;; This might have interrupts locked for a long time, and thus is an
+ ;; argument for using something like a semaphore to control access.
+ (without-interrupts
+ (lambda ()
+ (set-generic-record/cache!
+ record
+ (purge-cache-entries (generic-record/cache record)
+ (lambda (tags) (filter generic tags)))))))
+
+(define (guarantee-generic-procedure generic caller)
+ (or (eqht/get generic-procedure-records generic #f)
+ (error:wrong-type-argument generic "generic procedure" caller)))
+
+(define (guarantee-generator generator caller)
+ (if (not (or (not generator)
+ (and (procedure? generator)
+ (procedure-arity-valid? generator 2))))
+ (error:wrong-type-argument generator
+ "generic procedure generator"
+ caller)))
+\f
+;;;; Generic Procedure Application
+
+(define (compute-apply-generic record)
+ (let ((arity (generic-record/arity record)))
+ (cond ((pair? arity) (apply-generic record))
+ ((= 1 arity) (apply-generic-1 record))
+ ((= 2 arity) (apply-generic-2 record))
+ ((= 3 arity) (apply-generic-3 record))
+ ((= 4 arity) (apply-generic-4 record))
+ (else (apply-generic record)))))
+
+(define (apply-generic record)
+ (let ((min-arity (generic-record/min-arity record))
+ (max-arity (generic-record/max-arity record)))
+ (let ((extra (and max-arity (- max-arity min-arity))))
+ (letrec
+ ((generic
+ (lambda args
+ (let loop ((args* args) (n min-arity) (tags '()))
+ (if (fix:= n 0)
+ (begin
+ (if (and extra
+ (let loop ((args* args*) (n extra))
+ (and (not (null? args*))
+ (or (fix:= n 0)
+ (loop (cdr args*)
+ (fix:- n 1))))))
+ (wna args))
+ (let ((procedure
+ (probe-cache (generic-record/cache record) tags)))
+ (if procedure
+ (apply procedure args)
+ (compute-method-and-store record args))))
+ (begin
+ (if (null? args*)
+ (wna args))
+ (loop (cdr args*)
+ (fix:- n 1)
+ (cons (dispatch-tag (car args*)) tags)))))))
+ (wna
+ (lambda (args)
+ (error:wrong-number-of-arguments generic
+ (generic-record/arity record)
+ args))))
+ generic))))
+
+(define (generic-procedure-applicable? procedure arguments)
+ (let ((record
+ (guarantee-generic-procedure procedure
+ 'GENERIC-PROCEDURE-APPLICABLE?))
+ (tags (map dispatch-tag arguments)))
+ (let ((generator (generic-record/generator record))
+ (arity (generic-record/arity record))
+ (n-args (length tags)))
+ (and generator
+ (if (pair? arity)
+ (let ((min-arity (arity-min arity))
+ (max-arity (arity-max arity)))
+ (if (fix:= n-args min-arity)
+ (generator procedure tags)
+ (and (fix:> n-args min-arity)
+ (or (not max-arity)
+ (fix:<= n-args max-arity))
+ (generator procedure (list-head tags min-arity)))))
+ (and (fix:= arity n-args)
+ (generator procedure tags)))))))
+\f
+(define (apply-generic-1 record)
+ (lambda (a1)
+ (declare (integrate-operator dispatch-tag))
+ (let ((procedure
+ (probe-cache-1 (generic-record/cache record)
+ (dispatch-tag a1))))
+ (if procedure
+ (procedure a1)
+ (compute-method-and-store record (list a1))))))
+
+(define (apply-generic-2 record)
+ (lambda (a1 a2)
+ (declare (integrate-operator dispatch-tag))
+ (let ((procedure
+ (probe-cache-2 (generic-record/cache record)
+ (dispatch-tag a1)
+ (dispatch-tag a2))))
+ (if procedure
+ (procedure a1 a2)
+ (compute-method-and-store record (list a1 a2))))))
+
+(define (apply-generic-3 record)
+ (lambda (a1 a2 a3)
+ (declare (integrate-operator dispatch-tag))
+ (let ((procedure
+ (probe-cache-3 (generic-record/cache record)
+ (dispatch-tag a1)
+ (dispatch-tag a2)
+ (dispatch-tag a3))))
+ (if procedure
+ (procedure a1 a2 a3)
+ (compute-method-and-store record (list a1 a2 a3))))))
+
+(define (apply-generic-4 record)
+ (lambda (a1 a2 a3 a4)
+ (declare (integrate-operator dispatch-tag))
+ (let ((procedure
+ (probe-cache-4 (generic-record/cache record)
+ (dispatch-tag a1)
+ (dispatch-tag a2)
+ (dispatch-tag a3)
+ (dispatch-tag a4))))
+ (if procedure
+ (procedure a1 a2 a3 a4)
+ (compute-method-and-store record (list a1 a2 a3 a4))))))
+
+(define (compute-method-and-store record args)
+ (let ((tags (map dispatch-tag args)))
+ (let ((procedure
+ (let ((generator (generic-record/generator record))
+ (generic (generic-record/procedure record)))
+ (or (and generator (generator generic tags))
+ (error:no-applicable-methods generic args)))))
+ (without-interrupts
+ (lambda ()
+ (set-generic-record/cache!
+ record
+ (fill-cache (generic-record/cache record) tags procedure))))
+ (apply procedure args))))
+\f
+;;;; Object Tags
+
+;;; We assume that most new data types will be constructed from tagged
+;;; vectors, and therefore we should optimize the path for such
+;;; structures as much as possible.
+
+(define (dispatch-tag object)
+ (declare (integrate object))
+ (declare (ignore-reference-traps (set microcode-type-tag-table
+ microcode-type-method-table)))
+ (if (and (%record? object)
+ (%record? (%record-ref object 0))
+ (eq? dispatch-tag-marker (%record-ref (%record-ref object 0) 0)))
+ (%record-ref object 0)
+ (or (vector-ref microcode-type-tag-table (object-type object))
+ ((vector-ref microcode-type-method-table (object-type object))
+ object))))
+
+(define (make-built-in-tag name)
+ (let ((entry (assq name built-in-tag-table)))
+ (if entry
+ (cdr entry)
+ (let ((tag (make-dispatch-tag name)))
+ (set! built-in-tag-table (cons (cons name tag) built-in-tag-table))
+ tag))))
+
+(define (built-in-dispatch-tags)
+ (map cdr built-in-tag-table))
+
+(define (built-in-dispatch-tag name)
+ (let ((entry (assq name built-in-tag-table)))
+ (and entry
+ (cdr entry))))
+
+(define condition-type:no-applicable-methods)
+(define error:no-applicable-methods)
+
+(define (initialize-conditions!)
+ (set! condition-type:no-applicable-methods
+ (make-condition-type 'NO-APPLICABLE-METHODS condition-type:error
+ '(OPERATOR OPERANDS)
+ (lambda (condition port)
+ (write-string "No applicable methods for " port)
+ (write (access-condition condition 'OPERATOR) port)
+ (write-string " with these arguments: " port)
+ (write (access-condition condition 'OPERANDS) port)
+ (write-string "." port))))
+ (set! error:no-applicable-methods
+ (condition-signaller condition-type:no-applicable-methods
+ '(OPERATOR OPERANDS)
+ standard-error-handler))
+ unspecific)
+\f
+;;;; Initialization
+
+(define standard-generic-procedure-tag)
+(define generic-procedure-records)
+(define built-in-tag-table)
+(define microcode-type-tag-table)
+(define microcode-type-method-table)
+
+(define (initialize-generic-procedures!)
+ (set! standard-generic-procedure-tag
+ (make-dispatch-tag 'STANDARD-GENERIC-PROCEDURE))
+ (set! generic-procedure-records (make-eqht))
+
+ ;; Initialize the built-in tag tables.
+ (set! built-in-tag-table '())
+ (set! microcode-type-tag-table
+ (make-initialized-vector (microcode-type/code-limit)
+ (lambda (code)
+ (make-built-in-tag
+ (or (microcode-type/code->name code) 'OBJECT)))))
+ (set! microcode-type-method-table
+ (make-vector (microcode-type/code-limit) #f))
+ (let ((assign-type
+ (lambda (name get-method)
+ (let ((code (microcode-type/name->code name)))
+ (vector-set! microcode-type-method-table code
+ (get-method
+ (vector-ref microcode-type-tag-table code)))
+ (vector-set! microcode-type-tag-table code #f)))))
+ (define-integrable (maybe-generic object default-tag)
+ (let ((record (eqht/get generic-procedure-records object #f)))
+ (if record
+ (generic-record/tag record)
+ default-tag)))
+ (let ((procedure-type
+ (lambda (default-tag)
+ (lambda (object)
+ (maybe-generic object default-tag)))))
+ (assign-type 'EXTENDED-PROCEDURE procedure-type)
+ (assign-type 'PROCEDURE procedure-type))
+ (assign-type
+ 'COMPILED-ENTRY
+ (let ((procedure-tag (make-built-in-tag 'COMPILED-PROCEDURE))
+ (return-address-tag (make-built-in-tag 'COMPILED-RETURN-ADDRESS))
+ (expression-tag (make-built-in-tag 'COMPILED-EXPRESSION)))
+ (lambda (default-tag)
+ (lambda (object)
+ (case (system-hunk3-cxr0
+ ((ucode-primitive compiled-entry-kind 1) object))
+ ((0) (maybe-generic object procedure-tag))
+ ((1) return-address-tag)
+ ((2) expression-tag)
+ (else default-tag))))))
+ (let ((boolean-tag (make-built-in-tag 'BOOLEAN)))
+ (if (> microcode-id/version 11)
+ (assign-type 'CONSTANT
+ (lambda (default-tag)
+ (lambda (object)
+ (if (or (eq? #f object) (eq? #t object))
+ boolean-tag
+ default-tag))))
+ (begin
+ (assign-type 'FALSE
+ (lambda (default-tag)
+ (lambda (object)
+ (if (eq? #f object)
+ boolean-tag
+ default-tag))))
+ (assign-type 'CONSTANT
+ (lambda (default-tag)
+ (lambda (object)
+ (if (eq? #t object)
+ boolean-tag
+ default-tag)))))))
+ (assign-type 'FLONUM
+ (let ((flonum-vector-tag
+ (make-built-in-tag 'FLONUM-VECTOR)))
+ (lambda (default-tag)
+ (lambda (object)
+ (if (fix:= 2 (system-vector-length object))
+ default-tag
+ flonum-vector-tag)))))
+ (assign-type 'RECORD
+ (let ((dt-tag (make-built-in-tag 'DISPATCH-TAG)))
+ (lambda (default-tag)
+ (lambda (object)
+ (if (eq? dispatch-tag-marker (%record-ref object 0))
+ dt-tag
+ default-tag)))))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: genmult.scm,v 1.1 1996/04/23 20:37:42 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Multiplexed Generic Procedures
+
+;;; This code assumes that a non-multiplexed generic procedure
+;;; generator is equivalent to the same generator stored in a
+;;; multiplexer. Multiplexers assume that each of their generators is
+;;; applicable to a particular set of objects, and that the set does
+;;; not intersect any of the sets handled by other generators stored
+;;; in the same multiplexer. Combining these two assumptions means
+;;; that a non-multiplexed generator must follow the convention for
+;;; multiplexed generators, even though there is no reason to do so in
+;;; the absence of multiplexers.
+
+;;; This convention is encouraged by hiding the low-level procedures
+;;; that allow direct access to a generic procedure's generator, and
+;;; forcing the programmer to go through the multiplexing interface.
+;;; That way, multiplexing appears to be an integral part of the
+;;; generic-procedure interface.
+
+(declare (usual-integrations))
+\f
+(define (generic-procedure-generator-list generic)
+ (let ((m (generic-procedure-generator generic)))
+ (if m
+ (if (multiplexer? m)
+ (list-copy (multiplexer-list m))
+ (list m))
+ '())))
+
+(define (add-generic-procedure-generator generic generator)
+ (let ((m (generic-procedure-generator generic)))
+ (if (multiplexer? m)
+ (begin
+ (purge-generic-procedure-cache generic)
+ (add-generator m generator))
+ (add-generator (install-multiplexer generic) generator))))
+
+(define (remove-generic-procedure-generator generic generator)
+ (let ((m (generic-procedure-generator generic)))
+ (if (multiplexer? m)
+ (begin
+ (purge-generic-procedure-cache generic)
+ (set-multiplexer-list! m (delq! generator (multiplexer-list m)))
+ (maybe-deinstall-multiplexer generic))
+ (if (eq? generator m)
+ (set-generic-procedure-generator! generic #f)))))
+
+(define (remove-generic-procedure-generators generic tags)
+ (for-each (lambda (generator)
+ (if (generator generic tags)
+ (remove-generic-procedure-generator generic generator)))
+ (generic-procedure-generator-list generic)))
+
+(define (generic-procedure-default-generator generic)
+ (let ((m (generic-procedure-generator generic)))
+ (and (multiplexer? m)
+ (multiplexer-default m))))
+
+(define (set-generic-procedure-default-generator! generic generator)
+ (let ((m (generic-procedure-generator generic)))
+ (cond ((multiplexer? m)
+ (purge-generic-procedure-cache generic)
+ (set-multiplexer-default! m generator)
+ (maybe-deinstall-multiplexer generic))
+ (generator
+ (set-multiplexer-default! (install-multiplexer generic)
+ generator)))))
+
+(define (install-multiplexer generic)
+ (let ((m (make-multiplexer)))
+ (let ((g (generic-procedure-generator generic)))
+ (if g
+ (add-generator m g)))
+ (set-generic-procedure-generator! generic m)
+ m))
+
+(define (add-generator m generator)
+ (set-multiplexer-list! m (cons generator (multiplexer-list m))))
+
+(define (maybe-deinstall-multiplexer generic)
+ (let* ((m (generic-procedure-generator generic))
+ (generators (multiplexer-list m)))
+ (cond ((and (null? generators)
+ (not (multiplexer-default m)))
+ (set-generic-procedure-generator! generic #f))
+ ((and (null? (cdr generators))
+ (not (multiplexer-default m)))
+ (set-generic-procedure-generator! generic (car generators))))))
+\f
+(define (make-multiplexer)
+ (make-entity (lambda (multiplexer generic tags)
+ (multiplexer-dispatch multiplexer generic tags))
+ (make-multiplexer-record '() #f)))
+
+(define (multiplexer? object)
+ (and (entity? object)
+ (multiplexer-record? (entity-extra object))))
+
+(define (multiplexer-list multiplexer)
+ (multiplexer-record/list (entity-extra multiplexer)))
+
+(define (set-multiplexer-list! multiplexer list)
+ (set-multiplexer-record/list! (entity-extra multiplexer) list))
+
+(define (multiplexer-default multiplexer)
+ (multiplexer-record/default (entity-extra multiplexer)))
+
+(define (set-multiplexer-default! multiplexer default)
+ (set-multiplexer-record/default! (entity-extra multiplexer) default))
+
+(define-structure (multiplexer-record (conc-name multiplexer-record/))
+ list
+ default)
+
+(define (multiplexer-dispatch multiplexer generic tags)
+ (let loop ((generators (multiplexer-list multiplexer)))
+ (if (null? generators)
+ (let ((default (multiplexer-default multiplexer)))
+ (and default
+ (default generic tags)))
+ (let ((procedure ((car generators) generic tags)))
+ (cond ((not procedure)
+ (loop (cdr generators)))
+ ((there-exists? (cdr generators)
+ (lambda (generator)
+ (generator generic tags)))
+ (lambda args
+ (error:extra-applicable-methods generic args)))
+ (else procedure))))))
+
+(define multiplexer-tag)
+(define del-rassq)
+(define condition-type:extra-applicable-methods)
+(define error:extra-applicable-methods)
+
+(define (initialize-multiplexer!)
+ (set! multiplexer-tag (list 'GENERIC-PROCEDURE-MULTIPLEXER))
+ (set! del-rassq (delete-association-procedure list-deletor eq? cdr))
+ unspecific)
+
+(define (initialize-conditions!)
+ (set! condition-type:extra-applicable-methods
+ (make-condition-type 'EXTRA-APPLICABLE-METHODS condition-type:error
+ '(OPERATOR OPERANDS)
+ (lambda (condition port)
+ (write-string "Too many applicable methods for " port)
+ (write (access-condition condition 'OPERATOR) port)
+ (write-string " with these arguments: " port)
+ (write (access-condition condition 'OPERANDS) port)
+ (write-string "." port))))
+ (set! error:extra-applicable-methods
+ (condition-signaller condition-type:extra-applicable-methods
+ '(OPERATOR OPERANDS)
+ standard-error-handler))
+ unspecific)
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: gentag.scm,v 1.1 1996/04/23 20:37:51 cph Exp $
+;;;
+;;; Copyright (c) 1993-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Tags for Generic Procedure Dispatch
+
+;;; From "Efficient Method Dispatch in PCL", Gregor Kiczales and Luis
+;;; Rodriguez, Proceedings of the 1990 ACM Conference on Lisp and
+;;; Functional Programming. Parts of this code are based on the
+;;; September 16, 1992 PCL implementation.
+
+(declare (usual-integrations))
+\f
+(define (make-dispatch-tag contents)
+ (let ((tag
+ (object-new-type
+ (ucode-type record)
+ ((ucode-primitive vector-cons) dispatch-tag-index-end #f))))
+ (%record-set! tag 0 dispatch-tag-marker)
+ (%record-set! tag 1 contents)
+ (do ((i dispatch-tag-index-start (fix:+ i 1)))
+ ((fix:= i dispatch-tag-index-end))
+ (%record-set! tag i (get-dispatch-tag-cache-number)))
+ tag))
+
+(define-integrable (dispatch-tag? object)
+ (and (%record? object)
+ (eq? dispatch-tag-marker (%record-ref object 0))))
+
+(define-integrable dispatch-tag-marker
+ ((ucode-primitive string->symbol) "#[dispatch-tag]"))
+
+(define-integrable dispatch-tag-index-start 2)
+(define-integrable dispatch-tag-index-end 10)
+(define-integrable dispatch-tag-ref %record-ref)
+(define-integrable dispatch-tag-set! %record-set!)
+
+(define (dispatch-tag-contents tag)
+ (guarantee-dispatch-tag tag 'DISPATCH-TAG-CONTENTS)
+ (%record-ref tag 1))
+
+(define (set-dispatch-tag-contents! tag contents)
+ (guarantee-dispatch-tag tag 'SET-DISPATCH-TAG-CONTENTS!)
+ (%record-set! tag 1 contents))
+
+(define-integrable (guarantee-dispatch-tag tag caller)
+ (if (not (dispatch-tag? tag))
+ (error:wrong-type-argument tag "dispatch tag" caller)))
+
+(declare (integrate-operator next-dispatch-tag-index))
+(define (next-dispatch-tag-index index)
+ (and (fix:< (fix:+ index 1) dispatch-tag-index-end)
+ (fix:+ index 1)))
+
+(define-integrable dispatch-tag-cache-number-adds-ok
+ ;; This constant controls the number of non-zero bits tag cache
+ ;; numbers will have.
+ ;;
+ ;; The value of this constant is the number of tag cache numbers
+ ;; that can be added and still be certain the result will be a
+ ;; fixnum. This is implicitly used by all the code that computes
+ ;; primary cache locations from multiple tags.
+ 4)
+
+(define get-dispatch-tag-cache-number)
+
+(define (initialize-tag-constants!)
+ (set! get-dispatch-tag-cache-number
+ (let ((modulus
+ (int:quotient
+ (let loop ((n 2)) (if (fix:fixnum? n) (loop (int:* n 2)) n))
+ dispatch-tag-cache-number-adds-ok))
+ (state (make-random-state)))
+ (lambda ()
+ (random modulus state))))
+ unspecific)
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: recslot.scm,v 1.1 1996/04/23 20:37:58 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Record Slot Access
+
+(declare (usual-integrations))
+\f
+(define (%record-accessor-generator name)
+ (lambda (generic tags)
+ generic
+ (let ((index (%record-slot-index (%record (car tags)) name)))
+ (and index
+ (%record-accessor index)))))
+
+(define (%record-modifier-generator name)
+ (lambda (generic tags)
+ generic
+ (let ((index (%record-slot-index (%record (car tags)) name)))
+ (and index
+ (%record-modifier index)))))
+
+(define (%record-initpred-generator name)
+ (lambda (generic tags)
+ generic
+ (let ((index (%record-slot-index (%record (car tags)) name)))
+ (and index
+ (%record-initpred index)))))
+
+(define-macro (generate-index-cases index limit expand-case)
+ `(CASE ,index
+ ,@(let loop ((i 1))
+ (if (= i limit)
+ `((ELSE (,expand-case ,index)))
+ `(((,i) (,expand-case ,i)) ,@(loop (+ i 1)))))))
+
+(define (%record-accessor index)
+ (generate-index-cases index 16
+ (lambda (index)
+ (declare (integrate index))
+ (lambda (record) (%record-ref record index)))))
+
+(define (%record-modifier index)
+ (generate-index-cases index 16
+ (lambda (index)
+ (declare (integrate index))
+ (lambda (record value) (%record-set! record index value)))))
+
+(define (%record-initpred index)
+ (generate-index-cases index 16
+ (lambda (index)
+ (declare (integrate index))
+ (lambda (record)
+ (not (eq? record-slot-uninitialized (%record-ref record index)))))))
+
+(define %record-slot-index)
+(define %record-slot-names)
+
+(define (initialize-record-slot-access!)
+ (set! %record-slot-index (make-generic-procedure 2 '%RECORD-SLOT-INDEX))
+ (add-generic-procedure-generator %record-slot-index
+ (lambda (generic tags)
+ generic
+ (and (record-type? (dispatch-tag-contents (car tags)))
+ (lambda (record name)
+ (record-type-field-index (record-type-descriptor record)
+ name
+ #f)))))
+ (set! %record-slot-names (make-generic-procedure 1 '%RECORD-SLOT-NAMES))
+ (add-generic-procedure-generator %record-slot-names
+ (lambda (generic tags)
+ generic
+ (and (record-type? (dispatch-tag-contents (car tags)))
+ (lambda (record)
+ (record-type-field-names (record-type-descriptor record)))))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: tvector.scm,v 1.1 1996/04/23 20:38:03 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science. Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Tagged Vectors
+
+(declare (usual-integrations))
+\f
+;;; These procedures are optimized for safety. Applications that need
+;;; speed are assumed to break this abstraction and use "%record"
+;;; calls to construct and access tagged vectors.
+
+(define (make-tagged-vector tag length)
+ (guarantee-dispatch-tag tag 'MAKE-TAGGED-VECTOR)
+ (guarantee-index-integer length 'MAKE-TAGGED-VECTOR)
+ (let ((result
+ (object-new-type (ucode-type record)
+ (make-vector (fix:+ length 1)
+ record-slot-uninitialized))))
+ (%record-set! result 0 tag)
+ result))
+
+(define (tagged-vector tag . elements)
+ (guarantee-dispatch-tag tag 'MAKE-TAGGED-VECTOR)
+ (object-new-type (ucode-type record) (apply vector tag elements)))
+
+(define (tagged-vector? object)
+ (and (%record? object)
+ (dispatch-tag? (%record-ref object 0))))
+
+(define (tagged-vector-tag vector)
+ (guarantee-tagged-vector vector 'TAGGED-VECTOR-TAG)
+ (%record-ref vector 0))
+
+(define (set-tagged-vector-tag! vector tag)
+ (guarantee-tagged-vector vector 'SET-TAGGED-VECTOR-TAG!)
+ (guarantee-dispatch-tag tag 'SET-TAGGED-VECTOR-TAG!)
+ (%record-set! vector 0 tag))
+
+(define (tagged-vector-length vector)
+ (guarantee-tagged-vector vector 'TAGGED-VECTOR-LENGTH)
+ (fix:- (%record-length vector) 1))
+
+(define (tagged-vector-element vector index)
+ (guarantee-tagged-vector-ref vector index 'TAGGED-VECTOR-ELEMENT)
+ (%record-ref vector (fix:+ index 1)))
+
+(define (set-tagged-vector-element! vector index value)
+ (guarantee-tagged-vector-ref vector index 'SET-TAGGED-VECTOR-ELEMENT!)
+ (%record-set! vector (fix:+ index 1) value))
+
+(define (tagged-vector-element-initialized? vector index)
+ (guarantee-tagged-vector-ref vector index
+ 'TAGGED-VECTOR-ELEMENT-INITIALIZED?)
+ (not (eq? (%record-ref vector (fix:+ index 1)) record-slot-uninitialized)))
+
+(define (guarantee-tagged-vector vector caller)
+ (if (not (tagged-vector? vector))
+ (error:wrong-type-argument vector "tagged vector" caller)))
+
+(define (guarantee-tagged-vector-ref vector index caller)
+ (guarantee-tagged-vector vector caller)
+ (guarantee-index-integer index caller)
+ (if (not (fix:< index (fix:- (%record-length vector) 1)))
+ (error:bad-range-argument index caller)))
+
+(define (guarantee-index-integer index caller)
+ (if (not (and (fix:fixnum? index) (fix:>= index 0)))
+ (error:wrong-type-argument vector "non-negative fixnum" caller)))
+
+(define record-slot-uninitialized)
+
+(define (initialize-tagged-vector!)
+ (set! record-slot-uninitialized (intern "#[record-slot-uninitialized]"))
+ unspecific)
\ No newline at end of file
projects / mit-scheme.git / commitdiff