Port prescheme filename and stub prescheme env
This commit is contained in:
parent
58871787bd
commit
d793730895
4
hall.scm
4
hall.scm
|
@ -37,7 +37,11 @@
|
|||
(scheme-file "transform")
|
||||
(scheme-file "transform4")
|
||||
(scheme-file "usual")))
|
||||
(directory
|
||||
"env"
|
||||
((scheme-file "stubs")))
|
||||
(scheme-file "environment")
|
||||
(scheme-file "filename")
|
||||
(scheme-file "locations")
|
||||
(scheme-file "memory")
|
||||
(scheme-file "platform")
|
||||
|
|
|
@ -29,6 +29,12 @@
|
|||
package-reader
|
||||
package-integrate?
|
||||
package-unstable?
|
||||
package-opens
|
||||
package-accesses
|
||||
package-file-name
|
||||
package-clauses
|
||||
set-package-integrate?!
|
||||
set-package-reader!
|
||||
structure-lookup ;;env.scm
|
||||
generic-lookup ;;inline.scm
|
||||
structure-interface ;;config.scm
|
||||
|
@ -40,7 +46,8 @@
|
|||
structure-package
|
||||
note-structure-name!
|
||||
$get-location
|
||||
environment-stable?))
|
||||
environment-stable?
|
||||
for-each-export))
|
||||
|
||||
;; --------------------
|
||||
;; Structures
|
||||
|
|
|
@ -8,6 +8,7 @@
|
|||
|
||||
(define-module (prescheme bcomp read-form)
|
||||
#:use-module (prescheme scheme48)
|
||||
#:use-module (prescheme filename)
|
||||
#:use-module (prescheme bcomp package)
|
||||
#:export (read-forms $note-file-package))
|
||||
|
||||
|
|
162
prescheme/bcomp/scan-package.scm
Normal file
162
prescheme/bcomp/scan-package.scm
Normal file
|
@ -0,0 +1,162 @@
|
|||
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
|
||||
;;;
|
||||
;;; Port Author: Andrew Whatson
|
||||
;;;
|
||||
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
|
||||
;;;
|
||||
;;; scheme48-1.9.2/scheme/bcomp/scan-package.scm
|
||||
;;;
|
||||
;;; Scanning structures and processing package clauses.
|
||||
;;;
|
||||
;;; Utility for compile-structures (link/link.scm) and
|
||||
;;; ensure-loaded (env/load-package.scm).
|
||||
;;;
|
||||
;;; Returns a list of all packages reachable from STRUCTS that answer true to
|
||||
;;; INCLUDE-THIS-PACKAGE?.
|
||||
|
||||
(define-module (prescheme bcomp scan-package)
|
||||
#:use-module (prescheme scheme48)
|
||||
#:use-module (prescheme filename)
|
||||
#:use-module (prescheme bcomp binding)
|
||||
#:use-module (prescheme bcomp cenv)
|
||||
#:use-module (prescheme bcomp mtype)
|
||||
#:use-module (prescheme bcomp package)
|
||||
#:use-module (prescheme bcomp read-form)
|
||||
#:export (collect-packages
|
||||
package-source))
|
||||
|
||||
(define (collect-packages structs include-this-package?)
|
||||
(let ((package-seen '())
|
||||
(structure-seen '())
|
||||
(packages '()))
|
||||
(letrec ((recur
|
||||
(lambda (structure visited)
|
||||
(if (memq (structure-package structure) visited)
|
||||
(warning 'collect-packages "cycle in structures dependencies"
|
||||
structure visited))
|
||||
(if (not (memq structure structure-seen))
|
||||
(begin
|
||||
(set! structure-seen (cons structure structure-seen))
|
||||
(let ((package (structure-package structure)))
|
||||
(if (not (memq package package-seen))
|
||||
(begin
|
||||
(set! package-seen (cons package package-seen))
|
||||
(if (include-this-package? package)
|
||||
(let ((visited (cons package visited)))
|
||||
(for-each (lambda (struct)
|
||||
(recur struct visited))
|
||||
(package-opens package))
|
||||
(for-each (lambda (name+struct)
|
||||
(recur (cdr name+struct) visited))
|
||||
(package-accesses package))
|
||||
(set! packages (cons package packages))))))))))))
|
||||
(for-each (lambda (struct)
|
||||
(recur struct '()))
|
||||
structs)
|
||||
(reverse packages))))
|
||||
|
||||
; Walk through PACKAGE's clauses to find the source code. The relevant
|
||||
; clauses are:
|
||||
; (files name ...)
|
||||
; (begin form ...)
|
||||
; (define-all-operators)
|
||||
; (usual-transforms name ...)
|
||||
;
|
||||
; Returns a list of pairs (file . (node1 node2 ...)), a list of names
|
||||
; of standard transforms, and a boolean value which is true if the package
|
||||
; is to include definitions of all primitives.
|
||||
|
||||
(define (package-source package)
|
||||
(let* ((config-file (package-file-name package))
|
||||
(dir (if config-file
|
||||
(file-name-directory config-file)
|
||||
#f)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(fold->3 (lambda (clause stuff transforms primitives?)
|
||||
(case (car clause)
|
||||
((files)
|
||||
(values (read-files (cdr clause) stuff dir package)
|
||||
transforms
|
||||
primitives?))
|
||||
((begin)
|
||||
(values (cons (cons config-file (cdr clause))
|
||||
stuff)
|
||||
transforms
|
||||
primitives?))
|
||||
((integrate)
|
||||
(set-package-integrate?! package
|
||||
(or (null? (cdr clause))
|
||||
(cadr clause)))
|
||||
(values stuff transforms primitives?))
|
||||
((optimize)
|
||||
(values stuff transforms primitives?))
|
||||
((define-all-operators)
|
||||
(values stuff transforms #t))
|
||||
((usual-transforms)
|
||||
(values stuff
|
||||
(append (reverse (cdr clause)) transforms)
|
||||
primitives?))
|
||||
((reader)
|
||||
(let ((r (force (comp-env-macro-eval (package->environment package)))))
|
||||
(set-package-reader! package ((car r) (cadr clause) (cdr r))))
|
||||
(values stuff transforms primitives?))
|
||||
(else
|
||||
(assertion-violation 'package-source
|
||||
"unrecognized define-structure keyword"
|
||||
clause))))
|
||||
(package-clauses package)
|
||||
'() '() #f))
|
||||
(lambda (stuff transforms primitives?)
|
||||
(values (reverse stuff)
|
||||
(reverse transforms)
|
||||
primitives?)))))
|
||||
|
||||
; Also prints out the filenames (courtesy of READ-FORMS).
|
||||
|
||||
(define (read-files all-files stuff dir package)
|
||||
(force-output (current-output-port)) ; just to be nice
|
||||
(fold (lambda (filespec stuff)
|
||||
(let ((file (namestring filespec
|
||||
dir
|
||||
*scheme-file-type*)))
|
||||
(display #\space (current-noise-port))
|
||||
(cons (cons file (read-forms file package #f))
|
||||
stuff)))
|
||||
all-files
|
||||
stuff))
|
||||
|
||||
(define (package-optimizer-names package)
|
||||
(if (package-integrate? package)
|
||||
(let ((opts (apply append
|
||||
(map cdr (filter (lambda (clause)
|
||||
(eq? (car clause) 'optimize))
|
||||
(package-clauses package))))))
|
||||
(reduce (lambda (name opts)
|
||||
(if (memq name opts)
|
||||
opts
|
||||
(cons name opts)))
|
||||
opts
|
||||
'()))
|
||||
'()))
|
||||
|
||||
(define (check-structure structure)
|
||||
(let ((undefined '()))
|
||||
(for-each-export
|
||||
(lambda (name want-type binding)
|
||||
(if (binding? binding)
|
||||
(let ((have-type (binding-type binding)))
|
||||
(if (not (compatible-types? have-type want-type))
|
||||
(warning 'check-structure
|
||||
"Type in interface doesn't match binding"
|
||||
name
|
||||
`(binding: ,(type->sexp have-type #t))
|
||||
`(interface: ,(type->sexp want-type #t))
|
||||
structure)))
|
||||
(set! undefined (cons name undefined))))
|
||||
structure)
|
||||
(if (not (null? undefined))
|
||||
(warning 'check-structure
|
||||
"Structure has undefined exports"
|
||||
structure
|
||||
undefined))))
|
43
prescheme/env/stubs.scm
vendored
Normal file
43
prescheme/env/stubs.scm
vendored
Normal file
|
@ -0,0 +1,43 @@
|
|||
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
|
||||
;;;
|
||||
;;; Port Author: Andrew Whatson
|
||||
;;;
|
||||
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Robert
|
||||
;;; Ransom, Marcus Crestani, Sebastian Rheinnecker
|
||||
;;;
|
||||
;;; scheme48-1.9.2/scheme/env/command.scm
|
||||
;;; scheme48-1.9.2/scheme/env/pacman.scm
|
||||
;;; scheme48-1.9.2/scheme/env/user.scm
|
||||
;;;
|
||||
;;; A minimal set of stubs from the Scheme 48 command processor needed for
|
||||
;;; prescheme compilation.
|
||||
|
||||
(define-module (prescheme env stubs)
|
||||
#:use-module (prescheme scheme48)
|
||||
#:export (config-package))
|
||||
|
||||
(define *user-context-initializers* '())
|
||||
|
||||
(define user-context
|
||||
(let ((ctx #f))
|
||||
(lambda ()
|
||||
(unless ctx
|
||||
(set! ctx (make-user-context)))
|
||||
ctx)))
|
||||
|
||||
(define (make-user-context)
|
||||
(let ((context (make-symbol-table)))
|
||||
(for-each (lambda (name+thunk)
|
||||
(table-set! context (car name+thunk) ((cdr name+thunk))))
|
||||
*user-context-initializers*)
|
||||
context))
|
||||
|
||||
(define (user-context-accessor name initializer)
|
||||
(set! *user-context-initializers*
|
||||
(append *user-context-initializers*
|
||||
(list (cons name initializer))))
|
||||
(lambda ()
|
||||
(table-ref (user-context) name)))
|
||||
|
||||
(define config-package
|
||||
(user-context-accessor 'config-package interaction-environment))
|
151
prescheme/filename.scm
Normal file
151
prescheme/filename.scm
Normal file
|
@ -0,0 +1,151 @@
|
|||
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
|
||||
;;;
|
||||
;;; Port Author: Andrew Whatson
|
||||
;;;
|
||||
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
|
||||
;;;
|
||||
;;; scheme48-1.9.2/scheme/big/filename.scm
|
||||
;;;
|
||||
;;; Silly file name utilities
|
||||
;;; These try to be operating-system independent, but fail, of course.
|
||||
;;;
|
||||
;;; Namelist = ((dir ...) basename type)
|
||||
;;; or ((dir ...) basename)
|
||||
;;; or (dir basename type)
|
||||
;;; or (dir basename)
|
||||
;;; or basename
|
||||
|
||||
(define-module (prescheme filename)
|
||||
#:use-module (prescheme scheme48)
|
||||
#:export (namestring *scheme-file-type* *load-file-type*
|
||||
file-name-directory
|
||||
file-name-nondirectory
|
||||
translate
|
||||
set-global-translation!
|
||||
set-translation!
|
||||
make-translations with-translations
|
||||
current-translations))
|
||||
|
||||
(define (namestring namelist dir default-type)
|
||||
(let* ((namelist (if (list? namelist) namelist (list '() namelist)))
|
||||
(subdirs (if (list? (car namelist))
|
||||
(car namelist)
|
||||
(list (car namelist))))
|
||||
(basename (cadr namelist))
|
||||
(type (if (null? (cddr namelist))
|
||||
(if (string? basename)
|
||||
#f
|
||||
default-type)
|
||||
(caddr namelist))))
|
||||
(string-append (or dir "")
|
||||
(apply string-append
|
||||
(map (lambda (subdir)
|
||||
(string-append
|
||||
(namestring-component subdir)
|
||||
directory-component-separator))
|
||||
subdirs))
|
||||
(namestring-component basename)
|
||||
(if type
|
||||
(string-append type-component-separator
|
||||
(namestring-component type))
|
||||
""))))
|
||||
|
||||
(define directory-component-separator "/") ;;unix sux
|
||||
(define type-component-separator ".")
|
||||
|
||||
(define (namestring-component x)
|
||||
(cond ((string? x) x)
|
||||
((symbol? x)
|
||||
(list->string (map file-name-preferred-case
|
||||
(string->list (symbol->string x)))))
|
||||
(else (assertion-violation 'namestring-component
|
||||
"bogus namelist component" x))))
|
||||
|
||||
(define file-name-preferred-case char-downcase)
|
||||
|
||||
(define *scheme-file-type* 'scm)
|
||||
(define *load-file-type* *scheme-file-type*) ;;#F for Pseudoscheme or T
|
||||
|
||||
|
||||
|
||||
;; Interface copied from gnu emacs:
|
||||
|
||||
;;file-name-directory
|
||||
;; Function: Return the directory component in file name NAME.
|
||||
;;file-name-nondirectory
|
||||
;; Function: Return file name NAME sans its directory.
|
||||
;;file-name-absolute-p
|
||||
;; Function: Return t if file FILENAME specifies an absolute path name.
|
||||
;;substitute-in-file-name
|
||||
;; Function: Substitute environment variables referred to in STRING.
|
||||
;;expand-file-name
|
||||
;; Function: Convert FILENAME to absolute, and canonicalize it.
|
||||
|
||||
(define (file-name-directory filename)
|
||||
(substring filename 0 (file-nondirectory-position filename)))
|
||||
|
||||
(define (file-name-nondirectory filename)
|
||||
(substring filename
|
||||
(file-nondirectory-position filename)
|
||||
(string-length filename)))
|
||||
|
||||
(define (file-nondirectory-position filename)
|
||||
(let loop ((i (- (string-length filename) 1)))
|
||||
(cond ((< i 0) 0)
|
||||
;; Heuristic. Should work for DOS, Unix, VMS, MacOS.
|
||||
((string-posq (string-ref filename i) "/:>]\\") (+ i 1))
|
||||
(else (loop (- i 1))))))
|
||||
|
||||
(define (string-posq thing s)
|
||||
(let loop ((i 0))
|
||||
(cond ((>= i (string-length s)) #f)
|
||||
((eq? thing (string-ref s i)) i)
|
||||
(else (loop (+ i 1))))))
|
||||
|
||||
|
||||
|
||||
;; Directory translations.
|
||||
;; E.g. (set-translation! "foo;" "/usr/mumble/foo/")
|
||||
|
||||
(define *global-translations* '())
|
||||
|
||||
(define $translations (make-fluid (make-cell '())))
|
||||
|
||||
(define (make-translations)
|
||||
(make-cell '()))
|
||||
|
||||
(define (with-translations translations thunk)
|
||||
(with-fluids (($translations (make-cell '()))) (thunk)))
|
||||
|
||||
(define (current-translations) (cell-ref (fluid-ref $translations)))
|
||||
(define (set-translations! new)
|
||||
(cell-set! (fluid-ref $translations) new))
|
||||
|
||||
(define (set-global-translation! from to)
|
||||
(set! *global-translations*
|
||||
(amend-alist! from to *global-translations*)))
|
||||
|
||||
(define (set-translation! from to)
|
||||
(set-translations! (amend-alist! from to (current-translations))))
|
||||
|
||||
(define (amend-alist! from to alist)
|
||||
(let ((probe (assoc from alist)))
|
||||
(if probe
|
||||
(begin
|
||||
(set-cdr! probe to)
|
||||
alist)
|
||||
(cons (cons from to) alist))))
|
||||
|
||||
(define (translate name)
|
||||
(let ((len (string-length name)))
|
||||
(let loop ((ts (append *global-translations* (current-translations))))
|
||||
(if (null? ts)
|
||||
name
|
||||
(let* ((from (caar ts))
|
||||
(to (cdar ts))
|
||||
(k (string-length from)))
|
||||
(if (and to
|
||||
(<= k len)
|
||||
(string=? (substring name 0 k) from))
|
||||
(string-append to (substring name k len))
|
||||
(loop (cdr ts))))))))
|
|
@ -6,6 +6,7 @@
|
|||
;;;
|
||||
;;; scheme48-1.9.2/scheme/big/big-util.scm
|
||||
;;; scheme48-1.9.2/scheme/big/more-port.scm
|
||||
;;; scheme48-1.9.2/scheme/rts/current-port.scm
|
||||
;;; scheme48-1.9.2/scheme/rts/exception.scm
|
||||
;;; scheme48-1.9.2/scheme/rts/util.scm
|
||||
|
||||
|
@ -57,6 +58,7 @@
|
|||
make-tracking-input-port
|
||||
make-tracking-output-port
|
||||
call-with-string-output-port
|
||||
current-noise-port
|
||||
write-one-line
|
||||
assertion-violation
|
||||
warning
|
||||
|
@ -76,6 +78,7 @@
|
|||
partition-list
|
||||
reduce
|
||||
fold
|
||||
fold->3
|
||||
every
|
||||
last)
|
||||
#:re-export (define-enumeration
|
||||
|
@ -140,6 +143,8 @@
|
|||
(define make-tracking-output-port identity)
|
||||
(define call-with-string-output-port call-with-output-string)
|
||||
|
||||
(define current-noise-port current-error-port)
|
||||
|
||||
(define (write-one-line port count proc)
|
||||
;; FIXME port write-one-line from scheme/big/more-port.scm
|
||||
(proc port))
|
||||
|
@ -248,6 +253,16 @@
|
|||
((null? list)
|
||||
accum)))
|
||||
|
||||
(define (fold->3 folder list acc0 acc1 acc2)
|
||||
(let loop ((list list) (acc0 acc0) (acc1 acc1) (acc2 acc2))
|
||||
(if (null? list)
|
||||
(values acc0 acc1 acc2)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(folder (car list) acc0 acc1 acc2))
|
||||
(lambda (acc0 acc1 acc2)
|
||||
(loop (cdr list) acc0 acc1 acc2))))))
|
||||
|
||||
(define (every pred l)
|
||||
(if (null? l)
|
||||
#t
|
||||
|
|
|
@ -13,6 +13,7 @@
|
|||
#:use-module (prescheme bcomp node)
|
||||
#:use-module (prescheme bcomp binding)
|
||||
#:use-module (prescheme bcomp package)
|
||||
#:use-module (prescheme bcomp scan-package)
|
||||
#:use-module (prescheme bcomp syntax)
|
||||
#:use-module (prescheme locations)
|
||||
#:use-module (ps-compiler node variable)
|
||||
|
|
|
@ -25,6 +25,7 @@
|
|||
#:use-module (ps-compiler node variable)
|
||||
#:use-module (ps-compiler prescheme eval)
|
||||
#:use-module ((ps-compiler prescheme form) #:select (variable-set!? make-form))
|
||||
#:use-module (ps-compiler prescheme linking)
|
||||
#:use-module (ps-compiler prescheme primitive)
|
||||
#:use-module (ps-compiler prescheme substitute)
|
||||
#:use-module (ps-compiler prescheme type)
|
||||
|
|
|
@ -17,9 +17,11 @@
|
|||
#: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))
|
||||
|
@ -111,9 +113,9 @@
|
|||
;;----------------------------------------------------------------
|
||||
;; Handy packages and package making stuff.
|
||||
|
||||
(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 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))
|
||||
|
@ -149,7 +151,7 @@
|
|||
loc
|
||||
#f)))
|
||||
|
||||
(define-for-syntax-value 'expand-define-record-type expand-define-record-type)
|
||||
;; (define-for-syntax-value 'expand-define-record-type expand-define-record-type)
|
||||
|
||||
;;----------------------------------------------------------------
|
||||
;; BASE-PACKAGE contains all of the primitives, syntax, etc. for Pre-Scheme
|
||||
|
|
Loading…
Reference in a new issue