123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259 |
- (define (package-specs->packages+exports struct-names files)
- (let ((config (make-very-simple-package 'config (list defpackage)))
- (old-config ((structure-ref package-commands-internal 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 (structure-ref meta-types syntax-type))
- (set-reflective-tower-maker! config (get-reflective-tower-maker old-config))
- (let-fluids (structure-ref packages-internal $get-location)
- (make-cell get-variable)
- (structure-ref reading-forms $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))))
- (define (get-variable package name)
-
- ((structure-ref variable make-global-variable)
- name
- (structure-ref ps-types type/unknown)))
- (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))))
-
- (define defpackage (structure-ref built-in-structures defpackage))
- (define structure-refs (structure-ref built-in-structures structure-refs))
- (define scheme (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.")))
- (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
- (structure-ref meta-types usual-variable-type)
- loc
- #f)))
- (define-for-syntax-value 'expand-define-record-type expand-define-record-type)
- (define (prescheme-unbound package name)
- (bug "~S has no binding in package ~S" name package))
- (define base-package
- (make-simple-package '()
- eval
- (make-env-for-syntax-promise
- scheme
- defrecord-for-syntax-structure)
- 'base-package))
- (let ((syntax-type (structure-ref meta-types syntax-type)))
- (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)))
- (let ((syntax-type (structure-ref meta-types syntax-type)))
- (for-each (lambda (name)
- (package-define! base-package
- name
- syntax-type
- #f
- (make-transform
- (usual-transform name)
- base-package
- (structure-ref meta-types syntax-type)
- `(usual-transform ',name)
- name)))
- '(and cond do let let* or quasiquote)))
- (define (define-prescheme! name location static)
- (package-define! base-package
- name
- (structure-ref meta-types usual-variable-type)
- location
- static))
- (define (import-syntax! package-id name)
- (let ((config ((structure-ref package-commands-internal config-package)))
- (syntax-type (structure-ref meta-types syntax-type)))
- (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)
- (load "prescheme/ps-syntax.scm" base-package)
- (eval '(define-syntax define-record-type expand-define-record-type)
- base-package)
- (define (get-interface name)
- (environment-ref ((structure-ref package-commands-internal 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))
- (define prescheme-compiler-env
- (package->environment base-package))
|