From b39c8f505e126324a12c6d47ce2575ad9f2c6553 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 7 Jan 2017 22:39:41 -0800 Subject: [PATCH] Implement predicate dispatching (generics using predicates). --- src/runtime/make.scm | 1 + src/runtime/predicate-dispatch.scm | 258 +++++++++++++++++++++++++++++ src/runtime/runtime.pkg | 50 ++++-- 3 files changed, 292 insertions(+), 17 deletions(-) create mode 100644 src/runtime/predicate-dispatch.scm diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 4ec950ce3..734eb8ae4 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -455,6 +455,7 @@ USA. (RUNTIME COMPOUND-PREDICATE) (RUNTIME PARAMETRIC-PREDICATE) (RUNTIME TAGGING) + (RUNTIME PREDICATE-DISPATCH) (RUNTIME HASH) (RUNTIME DYNAMIC) (RUNTIME REGULAR-SEXPRESSION) diff --git a/src/runtime/predicate-dispatch.scm b/src/runtime/predicate-dispatch.scm new file mode 100644 index 000000000..b5c6c633a --- /dev/null +++ b/src/runtime/predicate-dispatch.scm @@ -0,0 +1,258 @@ +#| -*-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, 2015, 2016, + 2017 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. + +|# + +;;;; Predicates: dispatch +;;; package: (runtime predicate-dispatch) + +(declare (usual-integrations)) + +(define predicate-dispatcher?) +(define maybe-get-metadata) +(define set-metadata!) +(define delete-metadata!) +(add-boot-init! + (lambda () + (let ((table (make-hashed-metadata-table))) + (set! predicate-dispatcher? (table 'has?)) + (set! maybe-get-metadata (table 'get-if-available)) + (set! set-metadata! (table 'put!)) + (set! delete-metadata! (table 'delete!))) + (register-predicate! predicate-dispatcher? 'predicate-dispatcher + '<= procedure?))) + +(define (get-metadata procedure caller) + (let ((metadata (maybe-get-metadata procedure #f))) + (if (not metadata) + (error:not-a predicate-dispatcher? procedure caller)) + metadata)) + +(define (make-predicate-dispatcher name arity make-handler-set) + (if (not (> (procedure-arity-min arity) 0)) + (error:bad-range-argument arity 'make-predicate-dispatcher)) + (let* ((metadata + (make-metadata name + arity + (make-handler-set (make-default-handler name)))) + (procedure (make-procedure arity metadata))) + (set-metadata! procedure metadata) + procedure)) + +(define (make-default-handler name) + (lambda args + (error "Inapplicable generic procedure:" name args))) + +(define (make-procedure arity metadata) + (let ((get-handler ((metadata-handler-set metadata) 'get-handler))) + (case (and (eqv? (procedure-arity-min arity) (procedure-arity-max arity)) + (procedure-arity-min arity)) + ((1) + (lambda (arg) + ((get-handler (list arg)) arg))) + ((2) + (lambda (arg1 arg2) + ((get-handler (list arg1 arg2)) arg1 arg2))) + ((3) + (lambda (arg1 arg2 arg3) + ((get-handler (list arg1 arg2 arg3)) arg1 arg2 arg3))) + ((4) + (lambda (arg1 arg2 arg3 arg4) + ((get-handler (list arg1 arg2 arg3 arg4)) arg1 arg2 arg3 arg4))) + (else + (lambda args + (apply (get-handler args) args)))))) + +(define (simple-predicate-dispatcher name arity) + (make-predicate-dispatcher name arity simple-handler-set)) + +(define (standard-predicate-dispatcher name arity) + (make-predicate-dispatcher name arity cached-most-specific-handler-set)) + +(define (chaining-predicate-dispatcher name arity) + (make-predicate-dispatcher name arity cached-chaining-handler-set)) + +(define-record-type + (make-metadata name arity handler-set) + metadata? + (name metadata-name) + (arity metadata-arity) + (handler-set metadata-handler-set)) + +(define (predicate-dispatcher-name dispatch) + (metadata-name (get-metadata dispatch 'predicate-dispatcher-name))) + +(define (predicate-dispatcher-arity dispatch) + (metadata-arity (get-metadata dispatch 'predicate-dispatcher-arity))) + +(define (predicate-dispatcher-rules dispatch) + (map list-copy + ((get-handler-set dispatch 'predicate-dispatcher-rules) 'get-rules))) + +(define (get-handler-set dispatch caller) + (metadata-handler-set (get-metadata dispatch caller))) + +(define (define-predicate-dispatch-handler dispatch predicates handler) + (let ((metadata (get-metadata dispatch 'define-predicate-dispatch-handler))) + (guarantee-list-of unary-procedure? predicates + 'define-predicate-dispatch-handler) + (guarantee-procedure-of-arity handler (metadata-arity metadata) + 'define-predicate-dispatch-handler) + ((metadata-handler-set metadata) 'set-handler! predicates handler))) + +(define (define-predicate-dispatch-default-handler dispatch handler) + ((get-handler-set dispatch 'define-predicate-dispatch-default-handler) + 'set-default-handler! handler)) + +;;;; Handler set implementations + +(define (simple-handler-set default-handler) + (let ((rules '())) + + (define (get-handler args) + (let loop ((rules rules)) + (if (pair? rules) + (if (predicates-match? (cdar rules) args) + (caar rules) + (loop (cdr rules))) + default-handler))) + + (define (set-handler! predicates handler) + (let ((rule + (find (lambda (rule) + (equal? (cdr rule) predicates)) + rules))) + (if rule + (let ((handler* (car rule))) + (if handler + (set-car! rule handler) + (set! rules (delq rule rules))) + handler*) + (begin + (if handler + (set! rules + (cons (cons handler predicates) + rules))) + #f)))) + + (define (get-default-handler) + default-handler) + + (define (set-default-handler! handler) + (set! default-handler handler) + unspecific) + + (lambda (operator) + (case operator + ((get-handler) get-handler) + ((set-handler!) set-handler!) + ((get-default-handler) get-default-handler) + ((set-default-handler!) set-default-handler!) + ((get-rules) (lambda () rules)) + (else (error "Unknown operator:" operator)))))) + +(define (predicates-match? predicates args) + (let loop ((predicates predicates) (args args)) + (or (not (pair? predicates)) + (and ((car predicates) (car args)) + (loop (cdr predicates) (cdr args)))))) + +(define (make-subsetting-handler-set make-effective-handler) + (lambda (default-handler) + (let* ((delegate (simple-handler-set default-handler)) + (delegate-get-rules (delegate 'get-rules)) + (delegate-get-default-handler (delegate 'get-default-handler))) + + (define (get-handler args) + (let ((matching + (let loop ((rules (delegate-get-rules)) (matching '())) + (if (pair? rules) + (loop (cdr rules) + (if (predicates-match? (cdar rules) args) + (cons (car rules) matching) + matching)) + matching)))) + (if (pair? matching) + (make-effective-handler (map car (sort matching ruletag)) + +(define (cached-chaining-handler-set) + (make-cached-handler-set (chaining-handler-set) object->tag)) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index f3b311cd8..d8008a2ce 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1823,6 +1823,39 @@ USA. predicate-template-predicate predicate-template?)) +(define-package (runtime tagging) + (files "tagging") + (parent (runtime)) + (export () + object->datum + object->predicate + object-tagger + set-tagged-object-unparser-method! + tag-object + tagged-object-datum + tagged-object-predicate + tagged-object?) + (export (runtime) + object->tag + tagged-object-tag) + (export (runtime unparser) + get-tagged-object-unparser-method)) + +(define-package (runtime predicate-dispatch) + (files "predicate-dispatch") + (parent (runtime)) + (export () + chaining-predicate-dispatcher + define-predicate-dispatch-default-handler + define-predicate-dispatch-handler + predicate-dispatcher-arity + predicate-dispatcher-name + predicate-dispatcher-rules + predicate-dispatcher? + standard-predicate-dispatcher) + (export (runtime) + simple-predicate-dispatcher)) + (define-package (runtime environment) (files "uenvir") (parent (runtime)) @@ -3646,23 +3679,6 @@ USA. %record-type-tag) (initialization (initialize-package!))) -(define-package (runtime tagging) - (files "tagging") - (parent (runtime)) - (export () - object->datum - object->predicate - object-tagger - set-tagged-object-unparser-method! - tag-object - tagged-object-datum - tagged-object-predicate - tagged-object?) - (export (runtime) - tagged-object-tag) - (export (runtime unparser) - get-tagged-object-unparser-method)) - (define-package (runtime reference-trap) (files "urtrap") (parent (runtime)) -- 2.25.1