From: Chris Hanson Date: Fri, 5 Jan 2018 07:11:29 +0000 (-0500) Subject: First draft of "bundle" support. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~425 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=951a675e0ac33b606b0cf2448a0de37bfa02db9d;p=mit-scheme.git First draft of "bundle" support. --- diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm new file mode 100644 index 000000000..bb97ed1c8 --- /dev/null +++ b/src/runtime/bundle.scm @@ -0,0 +1,182 @@ +#| -*- Mode: Scheme; keyword-style: none -*- + +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. + +|# + +;;;; Bundles + +;;; A bundle is a set of named objects implemented as a procedure. When called, +;;; the first argument to the bundle is a symbol identifying the named object to +;;; call, and the rest of the bundle's arguments are passed to the selected +;;; procedure. If the specified named object isn't a procedure, an error is +;;; signaled. + +;;; Each bundle also carries a predicate that can be used to identify it. +;;; Normally the predicate is shared between bundles with the same general +;;; structure. New bundle types are typically defined using define-interface. + +(declare (usual-integrations)) + +(define (make-bundle-interface name clauses) + (guarantee symbol? name 'make-bundle-interface) + (guarantee clauses? clauses 'make-bundle-interface) + (letrec* + ((predicate + (lambda (datum) + (and (bundle? datum) + (tag<= (bundle-tag datum) tag)))) + (tag + (make-tag name + predicate + predicate-tagging-strategy:never + 'make-bundle-interface + (make-bim name (copy-clauses clauses))))) + (set-tag<=! tag the-bundle-tag) + predicate)) + +(define (bundle-interface? object) + (and (predicate? object) + (bim? (tag-extra (predicate->tag object))))) + +(define (bundle-interface-name interface) + (bim-name (tag-extra (predicate->tag interface)))) + +(define (bundle-interface-clauses interface) + (copy-clauses (bim-clauses (tag-extra (predicate->tag interface))))) + +(define-record-type + (make-bim name clauses) + bim? + (name bim-name) + (clauses bim-clauses)) + +(define (clauses? object) + (and (list? object) + (every (lambda (p) + (or (symbol? p) + (and (pair? p) + (symbol? (car p)) + (list? (cdr p)) + (every (lambda (r) + (and (pair? r) + (symbol? (car r)) + (list? (cdr r)))) + (cdr p))))) + object) + (let ((clause-name + (lambda (clause) + (if (symbol? clause) + clause + (car clause))))) + (let loop ((clauses object)) + (if (pair? clauses) + (and (not (any (let ((name (clause-name (car clauses)))) + (lambda (clause) + (eq? name (clause-name clause)))) + (cdr clauses))) + (loop (cdr clauses))) + #t))))) + +(define (copy-clauses clauses) + (map (lambda (clause) + (if (symbol? clause) + (list clause) + (cons (car clause) + (map list-copy (cdr clause))))) + clauses)) + +(define (make-bundle interface alist) + (guarantee bundle-interface? interface 'make-bundle) + (guarantee bundle-alist? alist 'make-bundle) + (let ((tag (predicate->tag interface))) + (check-bundle-alist alist tag) + (make-entity (lambda (self operator . args) + (apply (bundle-ref self operator) args)) + (make-bundle-metadata tag (alist-copy alist))))) + +(define (bundle-alist? object) + (and (alist? object) + (every (lambda (p) + (symbol? (car p))) + object))) + +(define (check-bundle-alist alist tag) + (let ((clauses (bim-clauses (tag-extra tag)))) + (if (not (lset= (lambda (a c) + (eq? (car a) (car c))) + alist + clauses)) + (error "Bundle alist doesn't match its clauses:" alist clauses)))) + +(define-record-type + (make-bundle-metadata tag alist) + bundle-metadata? + (tag bundle-metadata-tag) + (alist bundle-metadata-alist)) + +(set-record-type-entity-unparser-method! + (bracketed-unparser-method + (lambda (bundle port) + (write (bim-name (tag-extra (bundle-tag bundle))) port) + (write-string " " port) + (write (object-hash bundle) port) + (let ((handler (bundle-ref bundle 'write-self #f))) + (if handler + (handler port)))))) + +(define (bundle? object) + (and (entity? object) + (bundle-metadata? (entity-extra object)))) + +(define (bundle-tag bundle) + (bundle-metadata-tag (entity-extra bundle))) + +(define (bundle-interface bundle) + (tag->predicate (bundle-tag bundle))) + +(define (%bundle-alist bundle) + (bundle-metadata-alist (entity-extra bundle))) + +(define (bundle-alist bundle) + (alist-copy (%bundle-alist bundle))) + +(define (bundle-names bundle) + (map car (%bundle-alist bundle))) + +(define (bundle-ref bundle operator #!optional default) + (let ((p (assq operator (%bundle-alist bundle)))) + (if p + (cdr p) + (begin + (if (default-object? default) + (error "Unknown bundle operator:" operator)) + default)))) + +(define the-bundle-tag) +(add-boot-init! + (lambda () + (register-predicate! bundle? 'bundle '<= entity?) + (set! the-bundle-tag (predicate->tag bundle?)) + (register-predicate! bundle-interface? 'bundle-interface '<= predicate?) + (register-predicate! clauses? 'interface-clauses))) \ No newline at end of file diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 4f8f8e2ba..caf8aaed6 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -480,6 +480,7 @@ USA. (RUNTIME HASH) (RUNTIME DYNAMIC) (RUNTIME REGULAR-SEXPRESSION) + (RUNTIME BUNDLE) ;; Microcode data structures (RUNTIME HISTORY) (RUNTIME SCODE) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 170e4d4db..1e112dc36 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -754,4 +754,73 @@ USA. (syntax-rules () ((unless condition form ...) (if (not condition) - (begin form ...))))) \ No newline at end of file + (begin form ...))))) + +(define-syntax :define-interface + (er-macro-transformer + (lambda (form rename compare) + (declare (ignore compare)) + (syntax-check '(_ identifier identifier + * (or symbol (symbol * (symbol * datum)))) + form) + (define-interface-helper rename + (cadr form) + (caddr form) + (cdddr form))))) + +(define (define-interface-helper rename constructor interface clauses) + (rename-generated-expression + rename + `(begin + ,(make-interface-definition constructor interface clauses) + ,(make-constructor-definition constructor interface + (map (lambda (clause) + (if (symbol? clause) + clause + (car clause))) + clauses))))) + +(define (make-interface-definition constructor interface clauses) + `(define ,interface + (make-bundle-interface ',constructor ',clauses))) + +(define (make-constructor-definition constructor interface names) + `(define-syntax ,constructor + (sc-macro-transformer + (lambda (form use-environment) + (if (not (null? (cdr form))) + (syntax-error "Ill-formed special form:" form)) + (list 'capture-bundle + ',interface + ,@(map (lambda (name) + `(close-syntax ',name use-environment)) + names)))))) + +(define (rename-generated-expression rename expr) + (let loop ((expr expr)) + (cond ((identifier? expr) + (rename expr)) + ((and (pair? expr) + (eq? 'quote (car expr)) + (pair? (cdr expr)) + (null? (cddr expr))) + (list (rename 'quote) + (cadr expr))) + ((and (pair? expr) + (list? (cdr expr))) + (cons (rename (car expr)) + (let ((rest (cdr expr))) + (case (car expr) + ((quote) + rest) + ((define define-syntax) + (cons (car rest) (loop (cdr rest)))) + (else + (map loop rest)))))) + (else expr)))) + +(define-syntax :capture-bundle + (syntax-rules () + ((_ predicate name ...) + (make-bundle predicate + (list (cons 'name name) ...))))) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 9cb593867..1a9e730ec 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1938,6 +1938,21 @@ USA. (export (runtime) simple-predicate-dispatcher)) +(define-package (runtime bundle) + (files "bundle") + (parent (runtime)) + (export () + bundle-alist + bundle-interface + bundle-interface-clauses + bundle-interface-name + bundle-interface? + bundle-names + bundle-ref + bundle? + make-bundle + make-bundle-interface)) + (define-package (runtime environment) (files "uenvir") (parent (runtime)) @@ -4699,6 +4714,7 @@ USA. (and-let* :and-let*) (assert :assert) (begin0 :begin0) + (capture-bundle :capture-bundle) (case :case) (circular-stream :circular-stream) (cond :cond) @@ -4707,6 +4723,7 @@ USA. (cons-stream* :cons-stream*) (define :define) (define-integrable :define-integrable) + (define-interface :define-interface) (define-record-type :define-record-type) (do :do) (fluid-let :fluid-let)