From d793730895aaeb4ee203f062ab3864af8fd1d5fd Mon Sep 17 00:00:00 2001 From: Andrew Whatson Date: Tue, 13 Sep 2022 15:58:44 +1000 Subject: [PATCH] Port prescheme filename and stub prescheme env --- hall.scm | 4 + prescheme/bcomp/package.scm | 9 +- prescheme/bcomp/read-form.scm | 1 + prescheme/bcomp/scan-package.scm | 162 ++++++++++++++++++++++++++++++ prescheme/env/stubs.scm | 43 ++++++++ prescheme/filename.scm | 151 ++++++++++++++++++++++++++++ prescheme/scheme48.scm | 15 +++ ps-compiler/prescheme/expand.scm | 1 + ps-compiler/prescheme/flatten.scm | 1 + ps-compiler/prescheme/linking.scm | 10 +- 10 files changed, 392 insertions(+), 5 deletions(-) create mode 100644 prescheme/bcomp/scan-package.scm create mode 100644 prescheme/env/stubs.scm create mode 100644 prescheme/filename.scm diff --git a/hall.scm b/hall.scm index c3a49b1..4ba45e7 100644 --- a/hall.scm +++ b/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") diff --git a/prescheme/bcomp/package.scm b/prescheme/bcomp/package.scm index 6ff3b43..3d9645d 100644 --- a/prescheme/bcomp/package.scm +++ b/prescheme/bcomp/package.scm @@ -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 diff --git a/prescheme/bcomp/read-form.scm b/prescheme/bcomp/read-form.scm index 55d00e8..8ecce8e 100644 --- a/prescheme/bcomp/read-form.scm +++ b/prescheme/bcomp/read-form.scm @@ -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)) diff --git a/prescheme/bcomp/scan-package.scm b/prescheme/bcomp/scan-package.scm new file mode 100644 index 0000000..f5f559f --- /dev/null +++ b/prescheme/bcomp/scan-package.scm @@ -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)))) diff --git a/prescheme/env/stubs.scm b/prescheme/env/stubs.scm new file mode 100644 index 0000000..378cbcd --- /dev/null +++ b/prescheme/env/stubs.scm @@ -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)) diff --git a/prescheme/filename.scm b/prescheme/filename.scm new file mode 100644 index 0000000..32a19a2 --- /dev/null +++ b/prescheme/filename.scm @@ -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)))))))) diff --git a/prescheme/scheme48.scm b/prescheme/scheme48.scm index 119e870..dea7f15 100644 --- a/prescheme/scheme48.scm +++ b/prescheme/scheme48.scm @@ -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 diff --git a/ps-compiler/prescheme/expand.scm b/ps-compiler/prescheme/expand.scm index 5fa82de..04d768c 100644 --- a/ps-compiler/prescheme/expand.scm +++ b/ps-compiler/prescheme/expand.scm @@ -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) diff --git a/ps-compiler/prescheme/flatten.scm b/ps-compiler/prescheme/flatten.scm index 3b86c3e..42abef4 100644 --- a/ps-compiler/prescheme/flatten.scm +++ b/ps-compiler/prescheme/flatten.scm @@ -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) diff --git a/ps-compiler/prescheme/linking.scm b/ps-compiler/prescheme/linking.scm index dc35cdf..87ea98d 100644 --- a/ps-compiler/prescheme/linking.scm +++ b/ps-compiler/prescheme/linking.scm @@ -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