guile-prescheme/ps-compiler/prescheme/linking.scm

;;; Part of Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey, Mike Sperber
;;;
;;;   scheme48-1.9.2/ps-compiler/prescheme/linking.scm
;;;
;;; This file has the Pre-Scheme compiler's code for dealing with the
;;; Scheme 48's module system.

(define-module (ps-compiler prescheme linking)
  #:use-module (prescheme scheme48)
  #:use-module (prescheme bcomp binding)
  #:use-module ((prescheme bcomp mtype) #:select (syntax-type usual-variable-type))
  #:use-module ((prescheme bcomp node) #:select (get-operator))
  #:use-module (prescheme bcomp interface)
  #:use-module (prescheme bcomp package)
  #:use-module (prescheme bcomp read-form)
  #:use-module (prescheme bcomp scan-package)
  #:use-module (prescheme bcomp transform)
  #:use-module (prescheme bcomp usual)
  #:use-module (prescheme environment)
  #:use-module (prescheme env stubs)
  #:use-module (prescheme locations)
  #:use-module ((ps-compiler node variable) #:select (make-global-variable))
  #:use-module ((ps-compiler prescheme type) #:select (type/unknown))
  #:use-module (ps-compiler util util)
  #:export (package-specs->packages+exports
            package-source
            define-prescheme!
            prescheme-compiler-env))

;; FILES is a list of files that contain structure definitions, including
;; a definition for NAME.  The files are loaded into a config package
;; containing:
;;   - the procedures and macros for defining structures and interfaces
;;   - a Pre-Scheme structure (called PRESCHEME)
;;   - a ps-memory structure
;;   - a ps-receive structure
;;   - the STRUCTURE-REFS structure
;; We then return:
;;   1. a list of the packages required to implement the named structures
;;   2. a list of the names exported by the named structures
;;   3. a procedure that for looking up names defined in packages in the
;;      config package (this is used to map user directives to their targets)

(define (package-specs->packages+exports struct-names files)
  (let ((config (make-very-simple-package 'config (list defpackage)))
        (old-config (config-package)))
    (environment-define! config 'prescheme prescheme)
    (environment-define! config 'ps-memory ps-memory)
    (environment-define! config 'ps-receive ps-receive)
    (environment-define! config 'ps-flonums ps-flonums)
    (environment-define! config 'ps-unsigned-integers ps-unsigned-integers)
    (environment-define! config 'ps-record-types ps-record-types)
    (environment-define! config 'structure-refs structure-refs)
    (environment-define! config ':syntax syntax-type)
    (set-reflective-tower-maker! config (get-reflective-tower-maker old-config))
    (with-fluids (($get-location
                   (make-cell get-variable))
                  ($note-file-package
                   (make-cell (lambda (filename package) (values)))))
      (lambda ()
        (for-each (lambda (file)
                    (load file config))
                  files)))
    (values (collect-packages (map (lambda (name)
                                     (environment-ref config name))
                                   struct-names)
                              (lambda (package)
                                #t))
            (let ((names '()))
              (for-each (lambda (struct-name)
                          (let ((my-names '()))
                            (for-each-declaration
                              (lambda (name package-name type)
                                (set! my-names (cons name my-names)))
                              (structure-interface
                                (environment-ref config struct-name)))
                            (set! names
                                  (cons (cons struct-name my-names)
                                        names))))
                        struct-names)
              names)
            (make-lookup config))))

;; This creates new variables as needed for packages.

(define (get-variable package name)
  ;;(format #t "Making variable ~S for ~S~%" name package)
  (make-global-variable
     name
     type/unknown))

;; Return something that will find the binding of ID in the package belonging
;; to the structure PACKAGE-ID in the CONFIG package.

(define (make-lookup config)
  (lambda (package-id id)
    (let ((binding (package-lookup config package-id)))
      (if (and (binding? binding)
               (location? (binding-place binding))
               (structure? (contents (binding-place binding))))
          (let* ((package (structure-package
                           (contents (binding-place binding))))
                 (binding (package-lookup package id)))
            (if (binding? binding)
                (binding-place binding)
                #f))
          #f))))

;;----------------------------------------------------------------
;; Handy packages and package making stuff.

(define defpackage     #f) ;; (structure-ref built-in-structures defpackage))
(define structure-refs #f) ;; (structure-ref built-in-structures structure-refs))
(define scheme         #f) ;; (structure-ref built-in-structures scheme))

(define (make-env-for-syntax-promise . structures)
  (make-reflective-tower eval structures 'prescheme-linking))

(define (make-very-simple-package name opens)
  (make-simple-package opens
                       eval
                       (make-env-for-syntax-promise scheme)
                       name))

(define (get-reflective-tower-maker p)
  (environment-ref p (string->symbol ".make-reflective-tower.")))

;;----------------------------------------------------------------
;; The following stuff is used to define the DEFINE-RECORD-TYPE macro.
;; We produce a structure that exports EXPAND-DEFINE-RECORD-TYPE.  The
;; base package then includes that structure in its FOR-SYNTAX package.

(define defrecord-for-syntax-package
  (make-very-simple-package 'defrecord-for-syntax-package '()))

(define defrecord-for-syntax-structure
  (make-structure defrecord-for-syntax-package
                  (lambda () (export expand-define-record-type))
                  'defrecord-for-syntax-structure))

(define (define-for-syntax-value id value)
  (let ((loc (make-new-location defrecord-for-syntax-package id)))
    (set-contents! loc value)
    (package-define! defrecord-for-syntax-package
                     id
                     usual-variable-type
                     loc
                     #f)))

;; (define-for-syntax-value 'expand-define-record-type expand-define-record-type)

;;----------------------------------------------------------------
;; BASE-PACKAGE contains all of the primitives, syntax, etc. for Pre-Scheme

(define (prescheme-unbound package name)
  (bug "~S has no binding in package ~S" name package))

(define base-package
;;  (let-fluid (structure-ref packages-internal $get-location) prescheme-unbound
;;    (lambda () ))
  (make-simple-package '()
                       eval
                       (make-env-for-syntax-promise
                          scheme
                          defrecord-for-syntax-structure)
                       'base-package))

;; Add the operators.

(for-each (lambda (id)
            (package-define! base-package
                             id
                             syntax-type
                             #f
                             (get-operator id syntax-type)))
          '(if begin lambda letrec quote set!
               define define-syntax let-syntax letrec-syntax
               ;; the rest are special for Prescheme
               goto type-case real-external))

;; Add the usual macros.

(for-each (lambda (name)
            (package-define! base-package
                             name
                             syntax-type
                             #f
                             (make-transform
                              (usual-transform name)
                              base-package
                              syntax-type
                              `(usual-transform ',name)
                              name)))
          '(and cond do let let* or quasiquote)) ;; delay

;; Plus whatever primitives are wanted.

(define (define-prescheme! name location static)
  (package-define! base-package
                   name
                   usual-variable-type
                   location
                   static))

;; Copy over the enumeration macros and the ERRORS enumeration.

(define (import-syntax! package-id name)
  (let ((config (config-package)))
    (let ((binding (structure-lookup (environment-ref config package-id)
                                     name
                                     #t)))
      (package-define! base-package
                       name
                       syntax-type
                       (binding-place binding)
                       (binding-static binding)))))

(import-syntax! 'enumerated 'define-enumeration)
(import-syntax! 'enumerated 'enum)
(import-syntax! 'enumerated 'name->enumerand)
(import-syntax! 'enumerated 'enumerand->name)
(import-syntax! 'prescheme  'errors)
(import-syntax! 'prescheme  'define-external-enumeration)
(import-syntax! 'scheme     'syntax-rules)

;; define still more syntax

(load "prescheme/ps-syntax.scm" base-package)

(eval '(define-syntax define-record-type expand-define-record-type)
      base-package)

;;(eval '(define-syntax define-union-type expand-define-union-type)
;;      base-package)

;;----------------------------------------------------------------
;; Make the Pre-Scheme structure and related structures

(define (get-interface name)
  (environment-ref (config-package)
                   name))

(define prescheme
  (make-structure base-package
                  (lambda () (get-interface 'prescheme-interface))
                  'prescheme))

(define ps-memory
  (make-structure base-package
                  (lambda () (get-interface 'ps-memory-interface))
                  'ps-memory))

(define ps-flonums
  (make-structure base-package
                  (lambda () (get-interface 'ps-flonums-interface))
                  'ps-flonums))

(define ps-unsigned-integers
  (make-structure base-package
                  (lambda () (get-interface 'ps-unsigned-integers-interface))
                  'ps-unsigned-integers))

(define ps-receive
  (make-structure base-package
                  (lambda () (get-interface 'ps-receive-interface))
                  'ps-receive))

(define ps-record-types
  (make-structure base-package
                  (lambda () (export (define-record-type :syntax)))
                  'ps-record-types))

;; and a handy environment

(define prescheme-compiler-env
  (package->environment base-package))