From: Taylor R Campbell Date: Sun, 5 Jul 2015 17:39:59 +0000 (+0000) Subject: Add error checking to entity and apply hook operations. X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~89 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2a447ff94f364fea9fe2169033a1e2c034592c8b;p=mit-scheme.git Add error checking to entity and apply hook operations. --- diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index c56ba71f4..55cabe5ce 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1638,6 +1638,10 @@ USA. (files "uproc") (parent (runtime)) (export () + %entity-extra + %entity-procedure + %set-entity-extra! + %set-entity-procedure! apply-hook-extra apply-hook-procedure apply-hook? diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 91477e946..2ea008e13 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -761,7 +761,7 @@ USA. ((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)) @@ -769,16 +769,16 @@ USA. (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 diff --git a/src/runtime/uproc.scm b/src/runtime/uproc.scm index de8a3e827..b40b860ec 100644 --- a/src/runtime/uproc.scm +++ b/src/runtime/uproc.scm @@ -332,41 +332,64 @@ USA. ;;;; 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)) + (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. @@ -376,19 +399,23 @@ USA. (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)) ;;;; Arity dispatched entities @@ -402,7 +429,7 @@ USA. 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) diff --git a/tests/check.scm b/tests/check.scm index 9cbefad40..105d934a8 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -45,6 +45,7 @@ USA. ("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" diff --git a/tests/runtime/test-entity.scm b/tests/runtime/test-entity.scm new file mode 100644 index 000000000..5d6ff2c6c --- /dev/null +++ b/tests/runtime/test-entity.scm @@ -0,0 +1,122 @@ +#| -*-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)) + +(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)))))