Also deletes a few unused files.
#|
-;;; Disabled because some procedures in conpar.scm and uenvir.scm
+;;; Disabled because some procedures in conpar.scm and environment.scm
;;; depend on the actual length for finding compiled code variables,
;;; etc.
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; DOS Directory Reader
-;;; package: (runtime directory)
-
-(declare (usual-integrations))
-\f
-(define directory-read/adjust-patterns? true)
-(define *expand-directory-prefixes?*)
-
-(define (initialize-package!)
- (set! *expand-directory-prefixes?* (make-unsettable-parameter #t))
- unspecific)
-
-(define (directory-read pattern #!optional sort?)
- (if (if (default-object? sort?) true sort?)
- (sort (directory-read-nosort pattern) pathname<?)
- (directory-read-nosort pattern)))
-
-(define (directory-read-nosort pattern)
- (let ((pattern
- (let ((pattern (adjust-directory-pattern (merge-pathnames pattern))))
- (if (directory-pathname? pattern)
- (make-pathname (pathname-host pattern)
- (pathname-device pattern)
- (pathname-directory pattern)
- 'WILD
- 'WILD
- (pathname-version pattern))
- pattern))))
- (let ((directory-path (directory-pathname pattern)))
- (map (lambda (pathname)
- (merge-pathnames pathname directory-path))
- (let ((pathnames
- (let ((fnames (generate-directory-pathnames directory-path)))
- (parameterize*
- (list (cons *expand-directory-prefixes?* false))
- (lambda ()
- (map ->pathname fnames))))))
- (if (and (eq? (pathname-name pattern) 'WILD)
- (eq? (pathname-type pattern) 'WILD))
- pathnames
- (list-transform-positive pathnames
- (let ((match-name
- (component-matcher (pathname-name pattern)))
- (match-type
- (component-matcher (pathname-type pattern))))
- (lambda (instance)
- (and (match-name (pathname-name instance))
- (match-type (pathname-type instance))))))))))))
-
-(define (adjust-directory-pattern pathname)
- (if (and directory-read/adjust-patterns?
- (not (pathname-type pathname))
- (let ((name (pathname-name pathname)))
- (and (string? name)
- (let ((len (string-length name)))
- (and (> len 0)
- (char=? (string-ref name (-1+ len)) #\*))))))
- (pathname-new-type pathname 'WILD)
- pathname))
-
-(define (generate-directory-pathnames pathname)
- (let ((channel (directory-channel-open (->namestring pathname))))
- (let loop ((result '()))
- (let ((name (directory-channel-read channel)))
- (if name
- (loop (cons name result))
- (begin
- (directory-channel-close channel)
- result))))))
-
-(define (pathname<? x y)
- (or (component<? (pathname-name x) (pathname-name y))
- (and (equal? (pathname-name x) (pathname-name y))
- (component<? (pathname-type x) (pathname-type y)))))
-
-(define (component<? x y)
- (and y
- (or (not x)
- (and (string? y)
- (or (not (string? x))
- (string<? x y))))))
-\f
-;;; This matcher does not currently understand question marks
-;;; but understands multiple asterisks.
-;;; Question marks are hard because in the presence of asterisks,
-;;; simple-minded left-to-right processing no longer works. e.g.
-;;; "*foo?bar*" matching "foogbazfoogbar".
-
-(define (component-matcher pattern)
- (cond ((or (eq? pattern 'WILD) (eq? pattern '#F))
- (lambda (instance)
- instance ; ignored
- true))
- ((and (string? pattern) (string-find-next-char pattern #\*))
- =>
- (lambda (posn)
- (let* ((len (string-length pattern))
- (posn*
- (string-find-next-char pattern #\* (1+ posn) len)))
- (if (not posn*)
- (simple-wildcard-matcher pattern posn)
- (let ((prefix (substring pattern 0 posn)))
- (let loop ((segments (list (substring pattern
- (1+ posn)
- posn*)))
- (posn posn*))
- (let* ((start (1+ posn))
- (posn*
- (string-find-next-char pattern #\* start len)))
- (if (not posn*)
- (full-wildcard-matcher
- prefix
- (list-transform-negative (reverse! segments)
- string-null?)
- (substring pattern start len))
- (loop (cons (substring pattern start posn*)
- segments)
- posn*)))))))))
- (else
- (lambda (instance)
- (equal? pattern instance)))))
-
-(define (simple-wildcard-matcher pattern posn)
- (let* ((len (string-length pattern))
- (min-len (-1+ len)))
- (cond ((zero? min-len)
- ;; e.g. "*"
- (lambda (instance)
- instance ; ignored
- true))
- ((zero? posn)
- ;; e.g. "*foo"
- (lambda (instance)
- (and (string? instance)
- (let ((len* (string-length instance)))
- (and (>= len* min-len)
- (substring=? pattern 1 len
- instance (- len* min-len) len*))))))
- ((= posn (-1+ len))
- ;; e.g. "bar*"
- (lambda (instance)
- (and (string? instance)
- (let ((len* (string-length instance)))
- (and (>= len* min-len)
- (substring=? pattern 0 min-len
- instance 0 min-len))))))
- (else
- ;; e.g. "foo*bar"
- (let* ((suffix-start (1+ posn))
- (suffix-len (- len suffix-start)))
- (lambda (instance)
- (and (string? instance)
- (let ((len* (string-length instance)))
- (and (>= len* min-len)
- (substring=? pattern 0 posn
- instance 0 posn)
- (substring=? pattern suffix-start len
- instance (- len* suffix-len)
- len*))))))))))
-\f
-(define (full-wildcard-matcher prefix segments suffix)
- (cond ((null? segments)
- ;; Degenerate case, e.g. "prefix**suffix"
- (simple-wildcard-matcher (string-append prefix "*" suffix)
- (string-length prefix)))
- #|
- ((null? (cdr segments))
- ;; Special case the single middle segment.
- ;; Disabled because it is hardly worth it.
- (let ((prelen (string-length prefix))
- (suflen (string-length suffix)))
- (let* ((middle (car segments))
- (midlen (string-length middle))
- (totlen (+ prelen midlen suflen)))
- (cond ((string-null? prefix)
- (if (string-null? suffix)
- ;; e.g. "*middle*"
- (lambda (instance)
- (and (string? instance)
- (let ((len (string-length instance)))
- (and (>= len totlen)
- (substring? middle instance)))))
- ;; e.g. "*middle*suffix"
- (lambda (instance)
- (and (string? instance)
- (let ((len (string-length instance)))
- (and (>= len totlen)
- (let ((end (- len suflen)))
- (and (substring=? suffix 0 suflen
- instance end len)
- (substring?
- middle
- (substring instance 0
- end))))))))))
- ((string-null? suffix)
- ;; e.g. "prefix*middle*"
- (lambda (instance)
- (and (string? instance)
- (let ((len (string-length instance)))
- (and (>= len totlen)
- (substring=? prefix 0 prelen
- instance 0 prelen)
- (substring? middle
- (substring instance prelen
- len)))))))
- (else
- ;; e.g. "prefix*middle*suffix"
- (lambda (instance)
- (and (string? instance)
- (let ((len (string-length instance)))
- (and (>= len totlen)
- (let ((end (- len suflen)))
- (substring=? prefix 0 prelen
- instance 0 prelen)
- (substring=? suffix 0 suflen
- instance end len)
- (substring? middle
- (substring instance prelen
- end))))))))))))
- |#
-
- ((and (null? (cdr segments))
- (string-null? prefix)
- (string-null? suffix))
- ;; Special case "*foo*"
- (let* ((middle (car segments))
- (totlen (string-length middle)))
- (lambda (instance)
- (and (string? instance)
- (>= (string-length instance) totlen)
- (substring? middle instance)))))
-\f
- (else
- (let* ((prelen (string-length prefix))
- (suflen (string-length suffix))
- (totlen (+ prelen
- (reduce + 0 (map string-length segments))
- suflen)))
-
- (define (segment-matcher segments)
- ;; This handles the "*foo*bar*baz*" part
- (let ((segment (car segments))
- (rest (cdr segments)))
- (if (null? rest)
- (lambda (instance)
- (substring? segment instance))
- (let ((next (segment-matcher rest))
- (len (string-length segment)))
- (lambda (instance)
- (let ((posn (string-search-forward segment instance)))
- (and posn
- (next
- (substring instance (+ posn len)
- (string-length instance))))))))))
-
- (let ((tester (segment-matcher segments)))
- (cond ((string-null? prefix)
- (if (string-null? suffix)
- ;; e.g. "*foo*bar*"
- (lambda (instance)
- (and (string? instance)
- (>= (string-length instance) totlen)
- (tester instance)))
- ;; e.g. "*foo*bar*suffix"
- (lambda (instance)
- (and (string? instance)
- (let ((len (string-length instance)))
- (and (>= len totlen)
- (let ((end (- len suflen)))
- (and (substring=? suffix 0 suflen
- instance end len)
- (tester (substring instance 0
- end))))))))))
-
- ((string-null? suffix)
- ;; e.g. "prefix*foo*bar*"
- (lambda (instance)
- (and (string? instance)
- (let ((len (string-length instance)))
- (and (>= len totlen)
- (substring=? prefix 0 prelen
- instance 0 prelen)
- (tester (substring instance prelen len)))))))
-
- (else
- ;; e.g. "prefix*foo*bar*suffix"
- (lambda (instance)
- (and (string? instance)
- (let ((len (string-length instance)))
- (and (>= len totlen)
- (let ((end (- len suflen)))
- (and (substring=? prefix 0 prelen
- instance 0 prelen)
- (substring=? suffix 0 suflen
- instance end len)
- (tester (substring instance prelen
- end)))))))))))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Miscellaneous DOS Primitives (emulation of unxprm version 1.16)
-;;; package: ()
-
-(declare (usual-integrations))
-\f
-(define (file-directory? filename)
- ((ucode-primitive file-directory? 1)
- (string-for-primitive (->namestring (merge-pathnames filename)))))
-
-(define (file-symbolic-link? filename)
- filename ; ignored
- false)
-
-(define (file-modes filename)
- ((ucode-primitive file-modes 1)
- (string-for-primitive (->namestring (merge-pathnames filename)))))
-
-(define (set-file-modes! filename modes)
- ((ucode-primitive set-file-modes! 2)
- (string-for-primitive (->namestring (merge-pathnames filename)))
- modes))
-
-(define (file-access filename amode)
- ((ucode-primitive file-access 2)
- (string-for-primitive (->namestring (merge-pathnames filename)))
- amode))
-;; upwards compatability
-(define dos/file-access file-access)
-
-(define (file-readable? filename)
- (file-access filename 4))
-
-(define (file-writeable? filename)
- (let ((pathname (merge-pathnames filename)))
- (let ((filename (string-for-primitive (->namestring pathname))))
- (or ((ucode-primitive file-access 2) filename 2)
- (and (not ((ucode-primitive file-exists? 1) filename))
- ((ucode-primitive file-access 2)
- (string-for-primitive (directory-namestring pathname))
- 2))))))
-
-;; upwards compatability
-(define file-writable? file-writeable?)
-
-(define (temporary-file-pathname #!optional directory)
- (let ((root
- (merge-pathnames "_scm_tmp"
- (if (or (default-object? directory) (not directory))
- (temporary-directory-pathname)
- (pathname-as-directory directory)))))
- (let loop ((ext 0))
- (let ((pathname (pathname-new-type root (number->string ext))))
- (if (allocate-temporary-file pathname)
- pathname
- (begin
- (if (> ext 999)
- (error "Can't find unique temporary pathname:" root))
- (loop (+ ext 1))))))))
-
-(define (temporary-directory-pathname)
- (let ((try-directory
- (lambda (directory)
- (let ((directory
- (pathname-as-directory (merge-pathnames directory))))
- (and (file-directory? directory)
- (file-writeable? directory)
- directory)))))
- (let ((try-variable
- (lambda (name)
- (let ((value (get-environment-variable name)))
- (and value
- (try-directory value))))))
- (or (try-variable "TEMP")
- (try-variable "TMP")
- (try-directory "/tmp")
- (try-directory "c:/")
- (try-directory ".")
- (try-directory "/")
- (error "Can't find temporary directory.")))))
-\f
-(define (file-attributes filename)
- ((ucode-primitive file-attributes 1)
- (string-for-primitive (->namestring (merge-pathnames filename)))))
-
-(define file-attributes-direct
- file-attributes)
-
-(define file-attributes-indirect
- file-attributes)
-
-(define-structure (file-attributes
- (type vector)
- (constructor false)
- (conc-name file-attributes/))
- (type false read-only true)
- (n-links false read-only true)
- (uid false read-only true)
- (gid false read-only true)
- (access-time false read-only true)
- (modification-time false read-only true)
- (change-time false read-only true)
- (length false read-only true)
- (mode-string false read-only true)
- (inode-number false read-only true))
-
-(define (file-length filename)
- (file-attributes/length (file-attributes filename)))
-
-(define (file-modification-time filename)
- ((ucode-primitive file-mod-time 1)
- (string-for-primitive (->namestring (merge-pathnames filename)))))
-
-(define file-modification-time-direct
- file-modification-time)
-
-(define file-modification-time-indirect
- file-modification-time)
-
-;; These are obviously incorrect, but there is no alternative.
-;; DOS only keeps track of modification times.
-
-(define file-access-time-direct
- file-modification-time-direct)
-
-(define file-access-time-indirect
- file-modification-time-indirect)
-
-(define file-access-time
- file-modification-time)
-
-(define (set-file-times! filename access-time modification-time)
- (let ((filename (->namestring (merge-pathnames filename)))
- (time (or modification-time
- access-time
- (file-modification-time-direct filename))))
- ((ucode-primitive set-file-times! 3)
- (string-for-primitive filename)
- (or access-time time)
- (or modification-time time))))
-\f
-(define get-environment-variable)
-(define set-environment-variable!)
-(define set-environment-variable-default!)
-(define delete-environment-variable!)
-(define reset-environment-variables!)
-(let ((environment-variables '())
- (environment-defaults '()))
-
- ;; Kludge: since getenv returns false for unbound,
- ;; that can also be the marker for a deleted variable
- (define-integrable *variable-deleted* false)
-
- (define (env-error proc var)
- (error "Variable must be a string:" var proc))
-
- (define (default-variable! var val)
- (if (and (not (assoc var environment-variables))
- (not ((ucode-primitive get-environment-variable 1)
- (string-for-primitive var))))
- (set! environment-variables
- (cons (cons var (if (procedure? val) (val) val))
- environment-variables)))
- unspecific)
-
- (set! get-environment-variable
- (lambda (variable)
- (if (not (string? variable))
- (env-error 'GET-ENVIRONMENT-VARIABLE variable))
- (let ((variable (string-upcase variable)))
- (cond ((assoc variable environment-variables)
- => cdr)
- (else
- ((ucode-primitive get-environment-variable 1)
- (string-for-primitive variable)))))))
-
- (set! set-environment-variable!
- (lambda (variable value)
- (if (not (string? variable))
- (env-error 'SET-ENVIRONMENT-VARIABLE! variable))
- (let ((variable (string-upcase variable)))
- (cond ((assoc variable environment-variables)
- => (lambda (pair) (set-cdr! pair value)))
- (else
- (set! environment-variables
- (cons (cons variable value) environment-variables)))))
- unspecific))
-
- (set! delete-environment-variable!
- (lambda (variable)
- (if (not (string? variable))
- (env-error 'DELETE-ENVIRONMENT-VARIABLE! variable))
- (set-environment-variable! variable *variable-deleted*)))
-
- (set! reset-environment-variables!
- (lambda ()
- (set! environment-variables '())
- (for-each (lambda (def) (default-variable! (car def) (cdr def)))
- environment-defaults)))
-
- (set! set-environment-variable-default!
- (lambda (var val)
- (if (not (string? var))
- (env-error 'SET-ENVIRONMENT-VARIABLE-DEFAULT! var))
- (let ((var (string-upcase var)))
- (cond ((assoc var environment-defaults)
- => (lambda (pair) (set-cdr! pair val)))
- (else
- (set! environment-defaults
- (cons (cons var val) environment-defaults))))
- (default-variable! var val))))
-
-) ; End LET
-\f
-(define (current-home-directory)
- (let ((home (get-environment-variable "HOME")))
- (if home
- (pathname-as-directory (merge-pathnames home))
- (user-home-directory (current-user-name)))))
-
-(define (current-user-name)
- (or (get-environment-variable "USER")
- "nouser"))
-
-(define (user-home-directory user-name)
- (or (and user-name
- (let ((directory (get-environment-variable "USERDIR")))
- (and directory
- (pathname-as-directory
- (pathname-new-name
- (pathname-as-directory (merge-pathnames directory))
- user-name)))))
- (merge-pathnames "\\")))
-
-(define (file-time->local-decoded-time time)
- (universal-time->local-decoded-time (file-time->universal-time time)))
-
-(define (decoded-time->file-time dt)
- (universal-time->file-time (decoded-time->universal-time dt)))
-
-(define (file-time->universal-time time) (+ time epoch))
-(define (universal-time->file-time time) (- time epoch))
-
-(define decode-file-time file-time->local-decoded-time)
-(define encode-file-time decoded-time->file-time)
-(define dos/user-home-directory user-home-directory)
-(define dos/current-user-name current-user-name)
-(define dos/current-home-directory current-home-directory)
-
-(define (file-touch filename)
- ((ucode-primitive file-touch 1)
- (string-for-primitive (->namestring (merge-pathnames filename)))))
-
-(define (make-directory name)
- ((ucode-primitive directory-make 1)
- (string-for-primitive
- (->namestring (directory-pathname-as-file (merge-pathnames name))))))
-
-(define (delete-directory name)
- ((ucode-primitive directory-delete 1)
- (string-for-primitive
- (->namestring (directory-pathname-as-file (merge-pathnames name))))))
-
-(define (file-line-ending pathname)
- pathname
- 'CRLF)
-
-(define (default-line-ending)
- 'CRLF)
-
-(define (initialize-system-primitives!)
- (let ((reset!
- (lambda ()
- (reset-environment-variables!)
- (cache-console-channel-descriptor!))))
- (reset!)
- (add-event-receiver! event:after-restart reset!)))
-\f
-(define (dos/fs-drive-type pathname)
- pathname
- (cons "FAT" ""))
-
-(define (dos/fs-long-filenames? pathname)
- pathname
- #f)
-
-(define (copy-file from to)
- (let ((input-filename (->namestring (merge-pathnames from)))
- (output-filename (->namestring (merge-pathnames to))))
- (let ((input-channel false)
- (output-channel false))
- (dynamic-wind
- (lambda ()
- (set! input-channel (file-open-input-channel input-filename))
- (set! output-channel
- (begin
- ((ucode-primitive file-remove-link 1)
- (string-for-primitive output-filename))
- (file-open-output-channel output-filename)))
- unspecific)
- (lambda ()
- (let ((source-length (channel-file-length input-channel))
- (buffer-length 8192))
- (if (zero? source-length)
- 0
- (let* ((buffer (make-legacy-string buffer-length))
- (transfer
- (lambda (length)
- (let ((n-read
- (channel-read-block input-channel
- buffer
- 0
- length)))
- (if (positive? n-read)
- (channel-write-block output-channel
- buffer
- 0
- n-read))
- n-read))))
- (let loop ((source-length source-length))
- (if (< source-length buffer-length)
- (transfer source-length)
- (let ((n-read (transfer buffer-length)))
- (if (= n-read buffer-length)
- (+ (loop (- source-length buffer-length))
- buffer-length)
- n-read))))))))
- (lambda ()
- (if output-channel (channel-close output-channel))
- (if input-channel (channel-close input-channel)))))
- (set-file-times! output-filename
- #f
- (file-modification-time input-filename))
- (set-file-modes! output-filename (file-modes input-filename))))
-\f
-(define (init-file-specifier->pathname specifier)
-
- (define (read-fat-init-file-map port)
- (let loop ((result '()))
- (let ((item (read port)))
- (if (eof-object? item)
- result
- (begin
- (if (not (and (pair? item)
- (init-file-specifier? (car item))
- (string? (cdr item))))
- (error "Malformed init-file map item:" item))
- (loop (cons item result)))))))
-
- (define (generate-fat-init-file directory)
- (let loop ((index 1))
- (let ((filename
- (string-append "ini"
- (string-pad-left (number->string index) 5 #\0)
- ".dat")))
- (if (file-exists? (merge-pathnames filename directory))
- (loop (+ index 1))
- filename))))
-
- (guarantee init-file-specifier? specifier 'INIT-FILE-SPECIFIER->PATHNAME)
- (let ((short-base (merge-pathnames "mitschem.ini/" (user-homedir-pathname))))
- (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base)))
- (let ((port #f))
- (dynamic-wind
- (lambda ()
- (set! port (open-i/o-file file-map-pathname))
- unspecific)
- (lambda ()
- (merge-pathnames
- (or (let ((entry
- (assoc specifier (read-fat-init-file-map port))))
- (and entry
- (cdr entry)))
- (let ((filename (generate-fat-init-file short-base)))
- (let ((channel (output-port-channel port)))
- (channel-file-set-position
- channel
- (channel-file-length channel)))
- (write (cons specifier filename) port)
- (newline port)
- filename))
- short-base))
- (lambda ()
- (if port
- (begin
- (close-port port)
- (set! port #f)
- unspecific))))))))
-
-(define console-channel-descriptor)
-
-(define (cache-console-channel-descriptor!)
- (set! console-channel-descriptor -1)
- unspecific)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Subprocess Support for DOS
-;;; package: (runtime)
-
-(declare (usual-integrations))
-\f
-(define run-subprocess
- (let ((prim (make-primitive-procedure 'run-subprocess 4))
- (channel-descriptor
- (access channel-descriptor (->environment '(runtime primitive-io)))))
-
- (lambda (string #!optional stdin stdout stderr)
- (define (run in out err)
- (let ((value (prim string in out err)))
- (cond ((zero? value)
- unspecific)
- ((< value 0)
- (error "run-subprocess: Not available"))
- (else
- (error "run-subprocess: Command failed" value)))))
-
- (define (with-channel-output-port port recvr)
- (call-with-temporary-filename
- (lambda (fname)
- (let ((value
- (call-with-output-file fname
- (lambda (port*)
- (recvr
- (channel-descriptor
- (output-port-channel port*)))))))
- (call-with-input-file fname
- (lambda (input)
- (let ((string (read-delimited-string (char-set) input)))
- (if (not (eof-object? string))
- (write-string string
- port)))))
- value))))
-
- (define (with-channel-input-port port recvr)
- (call-with-temporary-filename
- (lambda (fname)
- (call-with-output-file fname
- (lambda (output)
- (write-string (read-delimited-string (char-set) port)
- output)))
- (call-with-input-file fname
- (lambda (port*)
- (recvr
- (channel-descriptor
- (input-port-channel port*))))))))
-
- (define (with-output-channel in out)
- (cond ((default-object? stderr)
- (run in out out))
- ((eq? stderr #t)
- (run in out -1))
- ((not (output-port? stderr))
- (error "run: stderr not an output port" stderr))
- ((output-port-channel stderr)
- =>
- (lambda (channel)
- (output-port/flush-output stderr)
- (run in out (channel-descriptor channel))))
- (else
- (with-channel-output-port stdout
- (lambda (err)
- (run in out err))))))
-
- (define (with-input-channel in)
- (let ((stdout
- (if (or (default-object? stdout)
- (not stdout))
- (let ((port (current-output-port)))
- (fresh-line port)
- port)
- stdout)))
- (cond ((eq? stdout #t)
- (with-output-channel in -1))
- ((not (output-port? stdout))
- (error "run: stdout not an output port" stdout))
- ((output-port-channel stdout)
- =>
- (lambda (channel)
- (output-port/flush-output stdout)
- (with-output-channel in (channel-descriptor channel))))
- (else
- (with-channel-output-port stdout
- (lambda (out)
- (with-output-channel in out)))))))
-
- (cond ((or (default-object? stdin)
- (eq? stdin #t))
- (with-input-channel -1))
- ((not (input-port? stdin))
- (error "run: stdin not an input port" stdin))
- ((input-port-channel stdin)
- => (lambda (channel)
- (with-input-channel (channel-descriptor channel))))
- (else
- (with-channel-input-port stdin
- with-input-channel))))))
\ No newline at end of file
("boole" (runtime boolean))
("boot" (runtime boot-definitions))
("char" (runtime character))
- ("chrset" (runtime character-set))
+ ("char-set" (runtime character-set))
("chrsyn" (runtime char-syntax))
("codwlk" (runtime scode-walker))
("condvar" (runtime thread condition-variable))
("conpar" (runtime continuation-parser))
+ ("console-io" (runtime console-i/o-port))
("contin" (runtime continuation))
("cpoint" (runtime control-point))
("cpress" (runtime compress))
("dbgutl" (runtime debugger-utilities))
("debug" (runtime debugger))
("defstr" (runtime syntax defstruct))
+ ("dispatch-cache" (runtime tagged-dispatch))
+ ("dispatch-tag" (runtime tagged-dispatch))
("division" (runtime integer-division))
- ("dospth" (runtime pathname dos))
+ ("dos-pathname" (runtime pathname dos))
("dosprm" ())
("dosproc" (runtime))
- ("dospth" (runtime pathname dos))
("dragon4" (runtime number))
("dynamic" (runtime dynamic))
("emacs" (runtime emacs-interface))
+ ("environment" (runtime environment))
("equals" (runtime equality))
("error" (runtime error-handler))
("events" (runtime event-distributor))
("ffi" (runtime ffi))
("file-attributes" (runtime file-attributes))
- ("fileio" (runtime file-i/o-port))
- ("fixart" (runtime fixnum-arithmetic))
+ ("file-io" (runtime file-i/o-port))
("floenv" (runtime floating-point-environment))
("format" (runtime format))
("framex" (runtime debugging-info))
("gcstat" (runtime gc-statistics))
("gdatab" (runtime global-database))
("gdbm" (runtime gdbm))
- ("gencache" (runtime tagged-dispatch))
- ("genio" (runtime generic-i/o-port))
- ("gentag" (runtime tagged-dispatch))
+ ("generic-io" (runtime generic-i/o-port))
("global" (runtime miscellaneous-global))
("graphics" (runtime graphics))
("hash" (runtime hash))
- ("hashtb" (runtime hash-table))
+ ("hash-table" (runtime hash-table))
("histry" (runtime history))
("html-form-codec" (runtime html-form-codec))
("http-client" (runtime http-client))
("http-syntax" (runtime http-syntax))
- ("httpio" (runtime http-i/o))
+ ("http-io" (runtime http-i/o))
("ieee754" ())
("infstr" (runtime compiler-info))
("infutl" (runtime compiler-info))
- ("input" (runtime input-port))
+ ("input-port" (runtime input-port))
("integer-bits" (runtime integer-bits))
- ("intrpt" (runtime interrupt-handler))
- ("io" (runtime primitive-io))
+ ("interrupt" (runtime interrupt-handler))
("keyword" (runtime keyword))
("lambda" (runtime lambda-abstraction))
("lambda-list" (runtime lambda-list))
("lambdx" (runtime alternative-lambda))
+ ("legacy-string" (runtime legacy-string))
("list" (runtime list))
("load" (runtime load))
("make" ())
+ ("microcode-data" (runtime microcode-data))
+ ("microcode-errors" (runtime microcode-errors))
+ ("microcode-tables" (runtime microcode-tables))
("mime-codec" (runtime mime-codec))
("mit-macros" (runtime mit-macros))
("mit-syntax" (runtime syntax mit))
("option" (runtime options))
("optiondb" ())
("ordvec" (runtime ordered-vector))
- ("output" (runtime output-port))
+ ("output-port" (runtime output-port))
("packag" (package))
- ("parse" (runtime parser))
+ ("parser" (runtime parser))
("parser-buffer" (runtime parser-buffer))
- ("pathnm" (runtime pathname))
+ ("pathname" (runtime pathname))
("pgsql" (runtime postgresql))
("poplat" (runtime population))
- ("port" (runtime port))
("pp" (runtime pretty-printer))
("prgcop" (runtime program-copier))
+ ("primitive-arithmetic" (runtime primitive-arithmetic))
+ ("primitive-io" (runtime primitive-io))
+ ("procedure" (runtime procedure))
("process" (runtime subprocess))
("prop1d" (runtime 1d-property))
("prop2d" (runtime 2D-property))
("srfi-1" (runtime srfi-1))
("stack-sample" (runtime stack-sampler))
("stream" (runtime stream))
- ("string" (runtime string))
- ("stringio" (runtime string-i/o-port))
+ ("string-io" (runtime string-i/o-port))
("structure-parser" (runtime structure-parser))
("swank" (runtime swank))
("symbol" (runtime symbol))
("sysclk" (runtime system-clock))
("sysmac" (runtime system-macros))
("system" (runtime system))
+ ("textual-port" (runtime port))
("thread" (runtime thread))
("thread-barrier" (runtime thread barrier))
("thread-low" (runtime thread))
("thread-queue" (runtime thread-queue))
- ("tscript" (runtime transcript))
- ("ttyio" (runtime console-i/o-port))
- ("udata" (runtime microcode-data))
- ("uenvir" (runtime environment))
- ("uerror" (runtime microcode-errors))
- ("unicode" (runtime unicode))
+ ("transcript" (runtime transcript))
+ ("unix-pathname" (runtime pathname unix))
("unpars" (runtime unparser))
("unsyn" (runtime unsyntaxer))
("unxdir" (runtime directory))
("unxprm" (runtime os-primitives))
- ("unxpth" (runtime pathname unix))
- ("uproc" (runtime procedure))
("url" (runtime uri))
("urtrap" (runtime reference-trap))
("usrint" (runtime user-interface))
- ("utabs" (runtime microcode-tables))
+ ("ustring" (runtime ustring))
("vector" (runtime vector))
("version" (runtime))
("where" (runtime environment-inspector))
|#
;;;; Legacy Strings
-;;; package: (runtime string)
+;;; package: (runtime legacy-string)
(declare (usual-integrations))
("boot" . (RUNTIME BOOT-DEFINITIONS))
("queue" . (RUNTIME SIMPLE-QUEUE))
("equals" . (RUNTIME EQUALITY))
- ("fixart" . (runtime fixnum-arithmetic))
("list" . (RUNTIME LIST))
+ ("primitive-arithmetic" . (runtime primitive-arithmetic))
("srfi-1" . (runtime srfi-1))
("thread-low" . (runtime thread))
("vector" . (RUNTIME VECTOR))))
(files1
'(("ustring" . (RUNTIME USTRING))
("symbol" . (RUNTIME SYMBOL))
- ("uproc" . (RUNTIME PROCEDURE))
+ ("procedure" . (runtime procedure))
("random" . (RUNTIME RANDOM-NUMBER))
- ("gentag" . (runtime tagged-dispatch))
+ ("dispatch-tag" . (runtime tagged-dispatch))
("poplat" . (RUNTIME POPULATION))
("record" . (RUNTIME RECORD))
("bundle" . (runtime bundle))))
|#
;;;; Low-level arithmetic
-;;; package: (runtime fixnum-arithmetic)
+;;; package: (runtime primitive-arithmetic)
(declare (usual-integrations))
\f
equal?
eqv?))
-(define-package (runtime fixnum-arithmetic)
- (files "fixart")
+(define-package (runtime primitive-arithmetic)
+ (files "primitive-arithmetic")
(parent (runtime))
- (export () deprecated:fixnum-arithmetic
+ (export () deprecated:primitive-arithmetic
(largest-fixnum fix:largest-value)
(smallest-fixnum fix:smallest-value))
(export ()
uninterned-symbol?))
(define-package (runtime microcode-data)
- (files "udata")
+ (files "microcode-data")
(parent (runtime))
(export ()
compiled-code-address->block
set-environment-variable!
set-environment-variable-default!))))
-(define-package (runtime string)
- (files "string")
+(define-package (runtime legacy-string)
+ (files "legacy-string")
(parent (runtime))
- (export () deprecated:string
+ (export () deprecated:legacy-string
(vector-8b? legacy-string?)
legacy-string?
make-legacy-string
(define-package (runtime ustring)
(files "ustring")
(parent (runtime))
- (export () deprecated:ustring
+ (export () deprecated:string
(string-ci-hash string-hash-ci)
(string-hash-mod string-hash)
(substring->list string->list)
char-set:symbol-initial))
(define-package (runtime character-set)
- (files "chrset")
+ (files "char-set")
(parent (runtime))
(export () deprecated:character-set
(char-set->scalar-values char-set->code-points)
string->char-set)
(export (runtime regular-sexpression)
normalize-ranges)
- (export (runtime string)
+ (export (runtime legacy-string)
(char-set-table %char-set-table)))
(define-package (runtime compiler-info)
(initialization (initialize-package!)))
(define-package (runtime console-i/o-port)
- (files "ttyio")
+ (files "console-io")
(parent (runtime))
(import (runtime primitive-io)
tty-input-channel
(initialization (initialize-package!)))
(define-package (runtime procedure)
- (files "uproc")
+ (files "procedure")
(parent (runtime))
(export ()
%entity-extra
make-bundle-interface))
(define-package (runtime environment)
- (files "uenvir")
+ (files "environment")
(parent (runtime))
(export ()
compiled-procedure/environment
(initialization (initialize-package!)))
(define-package (runtime file-i/o-port)
- (files "fileio")
+ (files "file-io")
(parent (runtime))
(export () deprecated:file-i/o-port
call-with-exclusive-legacy-binary-output-file
(initialization (initialize-package!)))
(define-package (runtime transcript)
- (files "tscript")
+ (files "transcript")
(parent (runtime))
(export ()
transcript-off
(initialization (initialize-package!)))
(define-package (runtime generic-i/o-port)
- (files "genio")
+ (files "generic-io")
(parent (runtime))
(export ()
binary->textual-port
(initialization (initialize-package!)))
(define-package (runtime hash-table)
- (files "hashtb")
+ (files "hash-table")
(parent (runtime))
(import (runtime population)
add-to-population!/unsafe)
synchronize-binary-output-port))
(define-package (runtime port)
- (files "port")
+ (files "textual-port")
(parent (runtime))
(export () deprecated:port
(i/o-port-type? textual-i/o-port-type?)
(initialization (initialize-package!)))
(define-package (runtime input-port)
- (files "input")
+ (files "input-port")
(parent (runtime))
(export () deprecated:input-port
make-eof-object
unread-char))
(define-package (runtime output-port)
- (files "output")
+ (files "output-port")
(parent (runtime))
(export () deprecated:output-port
(flush-output flush-output-port)
(initialization (initialize-package!)))
(define-package (runtime interrupt-handler)
- (files "intrpt")
+ (files "interrupt")
(parent (runtime))
(export ()
event:console-resize)
(initialization (initialize-package!)))
(define-package (runtime microcode-errors)
- (files "uerror")
+ (files "microcode-errors")
(parent (runtime error-handler))
(export ()
condition-type:anomalous-microcode-error
(initialization (initialize-package!)))
(define-package (runtime microcode-tables)
- (files "utabs")
+ (files "microcode-tables")
(parent (runtime))
(export ()
microcode-id/compiled-code-type
(initialization (initialize-package!)))
(define-package (runtime parser)
- (files "parse")
+ (files "parser")
(parent (runtime))
(export () deprecated:parser
(param:parser-canonicalize-symbols? param:parser-fold-case?)
parse-file-attributes-string))
(define-package (runtime pathname)
- (files "pathnm")
+ (files "pathname")
(parent (runtime))
(export ()
*default-pathname-defaults*
(initialization (initialize-package!)))
(define-package (runtime pathname unix)
- (files "unxpth")
+ (files "unix-pathname")
(parent (runtime pathname))
(initialization (initialize-package!)))
(define-package (runtime pathname dos)
- (files "dospth")
+ (files "dos-pathname")
(parent (runtime pathname))
(initialization (initialize-package!)))
(initialization (initialize-package!)))
(define-package (runtime primitive-io)
- (files "io")
+ (files "primitive-io")
(parent (runtime))
(export ()
all-dld-handles
(initialization (initialize-package!)))
(define-package (runtime string-i/o-port)
- (files "stringio")
+ (files "string-io")
(parent (runtime))
(export () deprecated:string-i/o-port
(get-output-from-accumulator get-output-string!)
gdbm_writer))
\f
(define-package (runtime tagged-dispatch)
- (files "gentag" "gencache")
+ (files "dispatch-tag" "dispatch-cache")
(parent (runtime))
(export ()
dispatch-metatag-constructor
write-http-headers))
(define-package (runtime http-i/o)
- (files "httpio")
+ (files "http-io")
(parent (runtime))
(export ()
http-message-body
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Switzerland site specific stuff
-
-(declare (usual-integrations))
-
-;;; Local hacks
-
-(define (call/cc . args)
- (warn "call/cc: Invoking the C compiler:" args)
- (warn "Segmentation fault (core dumped)"))
-
-(set-environment-variable-default! "MITSCHEME_INF_DIRECTORY" "\\scheme")
-(set-environment-variable-default!
- "TERM"
- (lambda ()
- (if (string-ci=? microcode-id/operating-system-name "NT")
- "ansi.sys"
- "ibm_pc_bios")))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Switzerland site specific stuff
-;;;; call/cc is used by the C back end!
-
-(declare (usual-integrations))
-
-;;; Local hacks
-
-(define *call/cc-warn?* true)
-(define *call/cc-c-compiler* "cc")
-
-(define (call/cc . args)
- (let ((command-line
- (with-output-to-string
- (lambda ()
- (write-string *call/cc-c-compiler*)
- (let loop ((args args))
- (if (not (null? args))
- (begin
- (write-string " ")
- (display (car args))
- (loop (cdr args)))))))))
- (if *call/cc-warn?*
- (warn "call/cc: Invoking the C compiler:" command-line))
- (system command-line)))
-
-(define (system command-line)
- (let ((inside (->namestring
- (directory-pathname-as-file (working-directory-pathname))))
- (outside false))
- (dynamic-wind
- (lambda ()
- (stop-thread-timer)
- (set! outside ((ucode-primitive working-directory-pathname 0)))
- ((ucode-primitive set-working-directory-pathname! 1) inside))
- (lambda ()
- ((ucode-primitive system 1) command-line))
- (lambda ()
- (set! inside ((ucode-primitive working-directory-pathname 0)))
- ((ucode-primitive set-working-directory-pathname! 1) outside)
- (start-thread-timer)))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff