;;; -*- Mode: Scheme -*-

;;;; Module-Local Syntactic Bindings
;;;; Scheme48 Implementation

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above copyright
;;;   notice, this list of conditions and the following disclaimer in
;;;   the documentation and/or other materials provided with the
;;;   distribution.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; This file implements a bizarre module-local syntactic binding
;;; mechanism.  If you want to describe a general class of resources
;;; that should be allocated locally to each module where they are
;;; used, but you want to write code that deals with them in common
;;; (again, depending on what module is using it), then you should use
;;; this abstraction.  To define a name for the module-local resource,
;;;
;;;   (DEFINE-MODULE-LOCAL <dispatcher-name> <display-name>)
;;;
;;; will define <dispatcher-name> for you to refer to with MODULE-LOCAL
;;; and SET-MODULE-LOCAL!.  <Display-name> has no semantic content; it
;;; is used only for display.  It should be distinct from
;;; <dispatcher-name>, however.  In any code that is expanded inside a
;;; particular module,
;;;
;;;   (MODULE-LOCAL (<continuation> . <environment>) <dispatcher-name>)
;;;
;;; will expand to (<continuation> <value> . <environment>), where
;;; <value> is the module-local value of the resource named by
;;; <dispatcher-name>.
;;;
;;;   (SET-MODULE-LOCAL! <dispatcher-name> <value>)
;;;
;;; will set the module-local value of the resource named by
;;; <dispatcher-name> to be <value>.  Any references to module-local
;;; resources should be preceded by assignments to initialize them.
;;; Note that the values involved need not be S-expressions; they can
;;; be *anything*at*all*.  Beware, though: if you want this to work on
;;; programs whose code you intend to dump to the disk, you must leave
;;; the final value as something that is dumpable, such as an
;;; S-expression.

(define-syntax define-module-local
  (lambda (form rename compare)
    (let ((dispatcher-name (cadr form))
          (display-name (caddr form)))
      (let ((generated-name (rename display-name))
            (%begin (rename 'BEGIN))
            (%define-syntax (rename 'DEFINE-SYNTAX))
            (&lambda (meta LAMBDA))
            (&let (meta LET))
            (&caadr (meta CAADR))
            (&cdadr (meta CDADR))
            (&cons (meta CONS))
            (&code-quote (meta CODE-QUOTE))
            (&syntax-error (meta SYNTAX-ERROR)))
        `(,%begin
           (,%define-syntax ,dispatcher-name
             (,&lambda (FORM RENAME COMPARE)
               RENAME COMPARE           ;ignore
               (,&let ((MACRO (,&caadr FORM))
                       (ENVIRONMENT (,&cdadr FORM)))
                 (,&cons MACRO
                         (,&cons (,&code-quote ,generated-name)
                                 ENVIRONMENT)))))
           ;; Unfortunately, this won't quite do what we want.
           (,%define-syntax ,generated-name
             (,&lambda (FORM RENAME COMPARE)
               FORM RENAME COMPARE      ;ignore
               (,&syntax-error "Reference to uninitialized module local:"
                               (,&code-quote ,generated-name))))))))
  (BEGIN DEFINE-SYNTAX))

(define-syntax module-local
  (syntax-rules ()
    ((MODULE-LOCAL continuation dispatcher-name)
     (dispatcher-name (MODULE-LOCAL/CONTINUE continuation)))))

(define-syntax module-local/continue
  (syntax-rules ()
    ((MODULE-LOCAL/CONTINUE name continuation)
     (name continuation))))

(define-syntax set-module-local!
  (syntax-rules ()
    ((SET-MODULE-LOCAL! dispatcher-name value)
     (dispatcher-name (SET-MODULE-LOCAL!/CONTINUE value)))))

(define-syntax set-module-local!/continue
  (lambda (form rename compare)
    (let ((name (cadr form))
          (value (caddr form))
          (%define-syntax (rename 'DEFINE-SYNTAX))
          (&lambda (meta LAMBDA))
          (&let (meta LET))
          (&caadr (meta CAADR))
          (&cdadr (meta CDADR))
          (&cons (meta CONS))
          (&code-quote (meta CODE-QUOTE)))
      `(,%define-syntax ,name
         (,&lambda (FORM RENAME COMPARE)
           RENAME COMPARE               ;ignore
           (,&let ((MACRO (,&caadr FORM))
                   (ENVIRONMENT (,&cdadr FORM)))
             (,&cons MACRO (,&cons (,&code-quote ,value) ENVIRONMENT)))))))
  (DEFINE-SYNTAX))