(files "uproc")
(parent (runtime))
(export ()
+ %entity-extra
+ %entity-procedure
+ %set-entity-extra!
+ %set-entity-procedure!
apply-hook-extra
apply-hook-procedure
apply-hook?
((apply-hook? entity)
(plain 'APPLY-HOOK))
((arity-dispatched-procedure? entity)
- (let ((proc (entity-procedure entity)))
+ (let ((proc (%entity-procedure entity)))
(cond ((and (compiled-code-address? proc)
(compiled-procedure? proc)
(compiled-procedure/name proc))
(else (plain 'ARITY-DISPATCHED-PROCEDURE)))))
((fluid *unparse-with-maximum-readability?*)
(*unparse-readable-hash entity))
- ((record? (entity-extra entity))
+ ((record? (%entity-extra entity))
;; Kludge to make the generic dispatch mechanism work.
(invoke-user-method
(lambda (state entity)
- ((record-entity-unparser (entity-extra entity)) state entity))
+ ((record-entity-unparser (%entity-extra entity)) state entity))
entity))
- ((or (and (vector? (entity-extra entity))
- (unparse-vector/entity-unparser (entity-extra entity)))
- (and (pair? (entity-extra entity))
- (unparse-list/entity-unparser (entity-extra entity))))
+ ((or (and (vector? (%entity-extra entity))
+ (unparse-vector/entity-unparser (%entity-extra entity)))
+ (and (pair? (%entity-extra entity))
+ (unparse-list/entity-unparser (%entity-extra entity))))
=> (lambda (method)
(invoke-user-method method entity)))
(else (plain 'ENTITY))))
\ No newline at end of file
\f
;;;; Entities and Apply Hooks
-(define-integrable (make-entity procedure extra)
+(define-integrable (%make-entity procedure extra)
(system-pair-cons (ucode-type entity) procedure extra))
(define-integrable (%entity? object)
(object-type? (ucode-type entity) object))
+(define-integrable (%entity-procedure entity)
+ (system-pair-car entity))
+
+(define-integrable (%set-entity-procedure! entity procedure)
+ (system-pair-set-cdr! entity procedure))
+
+(define-integrable (%entity-extra entity)
+ (system-pair-cdr entity))
+
+(define-integrable (%set-entity-extra! entity procdure)
+ (system-pair-set-cdr! entity extra))
+
(define (entity? object)
(and (%entity? object)
(not (%entity-is-apply-hook? object))))
-(define-integrable (entity-procedure entity)
- (system-pair-car entity))
+(define-guarantee entity "entity")
-(define-integrable (entity-extra entity)
- (system-pair-cdr entity))
+(define (make-entity procedure extra)
+ (%make-entity procedure extra))
+
+(define (entity-procedure entity)
+ (guarantee-entity entity 'ENTITY-PROCEDURE)
+ (%entity-procedure entity))
+
+(define (entity-extra entity)
+ (guarantee-entity entity 'ENTITY-EXTRA)
+ (%entity-extra entity))
(define (set-entity-procedure! entity procedure)
+ (guarantee-entity entity 'SET-ENTITY-PROCEDURE!)
(if (procedure-chains-to procedure entity)
(error:bad-range-argument procedure 'SET-ENTITY-PROCEDURE!))
- (system-pair-set-car! entity procedure))
-
-(define-integrable (set-entity-extra! entity extra)
- (system-pair-set-cdr! entity extra))
+ (%set-entity-procedure! entity procedure))
+(define (set-entity-extra! entity extra)
+ (guarantee-entity entity 'SET-ENTITY-EXTRA!)
+ (%set-entity-extra! entity extra))
+\f
(define (make-apply-hook procedure extra)
- (make-entity (lambda (entity . args)
- (apply (apply-hook-procedure entity) args))
- (hunk3-cons apply-hook-tag procedure extra)))
+ (%make-entity (lambda (entity . args)
+ (apply (apply-hook-procedure entity) args))
+ (hunk3-cons apply-hook-tag procedure extra)))
(define (apply-hook? object)
(and (%entity? object)
(%entity-is-apply-hook? object)))
+(define-guarantee apply-hook "apply-hook")
+
(define-integrable (%entity-is-apply-hook? object)
- (%entity-extra/apply-hook? (entity-extra object)))
+ (%entity-extra/apply-hook? (%entity-extra object)))
(define (%entity-extra/apply-hook? extra)
;; The wabbit cares about this one.
(define apply-hook-tag
"apply-hook-tag")
-(define-integrable (apply-hook-procedure apply-hook)
- (system-hunk3-cxr1 (entity-extra apply-hook)))
+(define (apply-hook-procedure apply-hook)
+ (guarantee-apply-hook apply-hook 'APPLY-HOOK-PROCEDURE)
+ (system-hunk3-cxr1 (%entity-extra apply-hook)))
-(define-integrable (apply-hook-extra apply-hook)
- (system-hunk3-cxr2 (entity-extra apply-hook)))
+(define (apply-hook-extra apply-hook)
+ (guarantee-apply-hook apply-hook 'APPLY-HOOK-EXTRA)
+ (system-hunk3-cxr2 (%entity-extra apply-hook)))
(define (set-apply-hook-procedure! apply-hook procedure)
+ (guarantee-apply-hook apply-hook 'SET-APPLY-HOOK-PROCEDURE!)
(if (procedure-chains-to procedure apply-hook)
(error:bad-range-argument procedure 'SET-APPLY-HOOK-PROCEDURE!))
- (system-hunk3-set-cxr1! (entity-extra apply-hook) procedure))
+ (system-hunk3-set-cxr1! (%entity-extra apply-hook) procedure))
-(define-integrable (set-apply-hook-extra! apply-hook procedure)
- (system-hunk3-set-cxr2! (entity-extra apply-hook) procedure))
+(define (set-apply-hook-extra! apply-hook procedure)
+ (guarantee-apply-hook apply-hook 'SET-APPLY-HOOK-EXTRA!)
+ (system-hunk3-set-cxr2! (%entity-extra apply-hook) procedure))
\f
;;;; Arity dispatched entities
dispatched-cases))))
(define (arity-dispatched-procedure? object)
- (and (%entity? object)
+ (and (entity? object)
(vector? (entity-extra object))
(fix:< 0 (vector-length (entity-extra object)))
(eq? (vector-ref (entity-extra object) 0)
("runtime/test-char-set" (runtime character-set))
"runtime/test-dynamic-env"
"runtime/test-division"
+ "runtime/test-entity"
"runtime/test-ephemeron"
"runtime/test-floenv"
"runtime/test-hash-table"
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Test of entities and apply hooks
+
+(declare (usual-integrations))
+\f
+(define (some-procedure foo)
+ foo)
+
+(define some-extra
+ (list 'FOO 42))
+
+((lambda (descriptors)
+ ((lambda (f)
+ (for-each (lambda (descriptor) (apply f descriptor)) descriptors))
+ (lambda (name constructor predicate get-procedure get-extra)
+ (define-test (symbol-append name '?)
+ (lambda ()
+ (assert-true (predicate (constructor some-procedure some-extra)))))
+ (define-test (symbol-append name '- 'PROCEDURE)
+ (lambda ()
+ (assert-eq some-procedure
+ (get-procedure (constructor some-procedure some-extra)))))
+ (define-test (symbol-append name '- 'EXTRA)
+ (lambda ()
+ (assert-eq
+ some-extra
+ (get-extra (constructor some-procedure some-extra)))))))
+ ((lambda (f)
+ (for-each (lambda (descriptor)
+ (for-each (lambda (descriptor*)
+ (if (not (eq? (car descriptor)
+ (car descriptor*)))
+ (apply f (append descriptor descriptor*))))
+ descriptors))
+ descriptors))
+ (lambda (name constructor predicate get-procedure get-extra
+ name* constructor* predicate* get-procedure* get-extra*)
+ constructor predicate* get-procedure* get-extra*
+ (define-test (symbol-append name '? '/ name*)
+ (lambda ()
+ (assert-false (predicate (constructor* some-procedure some-extra)))))
+ (define-test (symbol-append name '? '/ 'JUNK)
+ (lambda ()
+ (assert-false (predicate some-extra))))
+ (define-test (symbol-append name '- 'PROCEDURE '/ name*)
+ (lambda ()
+ (let ((object* (constructor* some-procedure some-extra)))
+ (assert-error (lambda ()
+ (get-procedure object*))
+ (list condition-type:wrong-type-argument)))))
+ (define-test (symbol-append name '- 'PROCEDURE '/ 'JUNK)
+ (lambda ()
+ (assert-error (lambda () (get-procedure some-extra))
+ (list condition-type:wrong-type-argument))))
+ (define-test (symbol-append name '- 'EXTRA '/ name*)
+ (lambda ()
+ (let ((object* (constructor* some-procedure some-extra)))
+ (assert-error (lambda () (get-extra object*))
+ (list condition-type:wrong-type-argument)))))
+ (define-test (symbol-append name '- 'EXTRA '/ 'JUNK)
+ (lambda ()
+ (assert-error (lambda () (get-extra some-extra))
+ (list condition-type:wrong-type-argument)))))))
+ `((ENTITY
+ ,make-entity ,entity? ,entity-procedure ,entity-extra)
+ (APPLY-HOOK
+ ,make-apply-hook ,apply-hook? ,apply-hook-procedure ,apply-hook-extra)))
+
+(define-test 'ENTITY-APPLICATION/0
+ (lambda ()
+ (let ((entity (make-entity some-procedure some-extra)))
+ (assert-eq entity (entity)))))
+
+(define-test 'ENTITY-APPLICATION/1
+ (lambda ()
+ (let ((entity (make-entity some-procedure some-extra)))
+ (assert-error (lambda () (entity 42))
+ (list condition-type:wrong-number-of-arguments)))))
+
+(define-test 'APPLY-HOOK-APPLICATION/0
+ (lambda ()
+ (let ((apply-hook (make-apply-hook some-procedure some-extra)))
+ (assert-error (lambda () (apply-hook))
+ (list condition-type:wrong-number-of-arguments)))))
+
+(define-test 'ENTITY-APPLICATION/1
+ (lambda ()
+ (assert-eqv 42 ((make-apply-hook some-procedure some-extra) 42))))
+
+(define-test 'ENTITY-CHAIN
+ (lambda ()
+ (let* ((e0 (make-entity some-procedure some-extra))
+ (e1 (make-entity e0 'ZARQUON))
+ (e2 (make-entity e1 'QUAGGA)))
+ (assert-error (lambda ()
+ (set-entity-procedure! e0 e2))
+ (list condition-type:bad-range-argument)))))
projects / mit-scheme.git / commitdiff