TakeV/guile-prescheme
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Port prescheme filename and stub prescheme env

Browse source
This commit is contained in:
Andrew Whatson 2022-09-13 15:58:44 +10:00
parent 58871787bd
commit d793730895
10 changed files with 392 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
hall.scm
View file

@ -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")

9
prescheme/bcomp/package.scm
View file

@ -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

1
prescheme/bcomp/read-form.scm
View file

@ -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
View 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
View 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
View 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))))))))

15
prescheme/scheme48.scm
View file

@ -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

1
ps-compiler/prescheme/expand.scm
View file

@ -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)

1
ps-compiler/prescheme/flatten.scm
View file

@ -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)

10
ps-compiler/prescheme/linking.scm
View file

@ -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