From 472007976d203e55644cd8a63043fb41bd7653f2 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 23 Jan 2018 00:06:06 -0800 Subject: [PATCH] Large number of file renames. Also deletes a few unused files. --- src/runtime/{chrset.scm => char-set.scm} | 0 src/runtime/{ttyio.scm => console-io.scm} | 0 src/runtime/cpoint.scm | 2 +- .../{gencache.scm => dispatch-cache.scm} | 0 src/runtime/{gentag.scm => dispatch-tag.scm} | 0 src/runtime/{dospth.scm => dos-pathname.scm} | 0 src/runtime/dosdir.scm | 323 -------------- src/runtime/dosprm.scm | 419 ------------------ src/runtime/dosproc.scm | 126 ------ src/runtime/ed-ffi.scm | 55 ++- src/runtime/{uenvir.scm => environment.scm} | 0 src/runtime/{fileio.scm => file-io.scm} | 0 src/runtime/{genio.scm => generic-io.scm} | 0 src/runtime/{hashtb.scm => hash-table.scm} | 0 src/runtime/{httpio.scm => http-io.scm} | 0 src/runtime/{input.scm => input-port.scm} | 0 src/runtime/{intrpt.scm => interrupt.scm} | 0 src/runtime/{string.scm => legacy-string.scm} | 2 +- src/runtime/make.scm | 6 +- src/runtime/{udata.scm => microcode-data.scm} | 0 .../{uerror.scm => microcode-errors.scm} | 0 .../{utabs.scm => microcode-tables.scm} | 0 src/runtime/{output.scm => output-port.scm} | 0 src/runtime/{parse.scm => parser.scm} | 0 src/runtime/{pathnm.scm => pathname.scm} | 0 .../{fixart.scm => primitive-arithmetic.scm} | 2 +- src/runtime/{io.scm => primitive-io.scm} | 0 src/runtime/{uproc.scm => procedure.scm} | 0 src/runtime/runtime.pkg | 62 +-- src/runtime/site.scm.dos | 43 -- src/runtime/site.scm.unix | 66 --- src/runtime/{stringio.scm => string-io.scm} | 0 src/runtime/{port.scm => textual-port.scm} | 0 src/runtime/{tscript.scm => transcript.scm} | 0 src/runtime/{unxpth.scm => unix-pathname.scm} | 0 35 files changed, 64 insertions(+), 1042 deletions(-) rename src/runtime/{chrset.scm => char-set.scm} (100%) rename src/runtime/{ttyio.scm => console-io.scm} (100%) rename src/runtime/{gencache.scm => dispatch-cache.scm} (100%) rename src/runtime/{gentag.scm => dispatch-tag.scm} (100%) rename src/runtime/{dospth.scm => dos-pathname.scm} (100%) delete mode 100644 src/runtime/dosdir.scm delete mode 100644 src/runtime/dosprm.scm delete mode 100644 src/runtime/dosproc.scm rename src/runtime/{uenvir.scm => environment.scm} (100%) rename src/runtime/{fileio.scm => file-io.scm} (100%) rename src/runtime/{genio.scm => generic-io.scm} (100%) rename src/runtime/{hashtb.scm => hash-table.scm} (100%) rename src/runtime/{httpio.scm => http-io.scm} (100%) rename src/runtime/{input.scm => input-port.scm} (100%) rename src/runtime/{intrpt.scm => interrupt.scm} (100%) rename src/runtime/{string.scm => legacy-string.scm} (95%) rename src/runtime/{udata.scm => microcode-data.scm} (100%) rename src/runtime/{uerror.scm => microcode-errors.scm} (100%) rename src/runtime/{utabs.scm => microcode-tables.scm} (100%) rename src/runtime/{output.scm => output-port.scm} (100%) rename src/runtime/{parse.scm => parser.scm} (100%) rename src/runtime/{pathnm.scm => pathname.scm} (100%) rename src/runtime/{fixart.scm => primitive-arithmetic.scm} (98%) rename src/runtime/{io.scm => primitive-io.scm} (100%) rename src/runtime/{uproc.scm => procedure.scm} (100%) delete mode 100644 src/runtime/site.scm.dos delete mode 100644 src/runtime/site.scm.unix rename src/runtime/{stringio.scm => string-io.scm} (100%) rename src/runtime/{port.scm => textual-port.scm} (100%) rename src/runtime/{tscript.scm => transcript.scm} (100%) rename src/runtime/{unxpth.scm => unix-pathname.scm} (100%) diff --git a/src/runtime/chrset.scm b/src/runtime/char-set.scm similarity index 100% rename from src/runtime/chrset.scm rename to src/runtime/char-set.scm diff --git a/src/runtime/ttyio.scm b/src/runtime/console-io.scm similarity index 100% rename from src/runtime/ttyio.scm rename to src/runtime/console-io.scm diff --git a/src/runtime/cpoint.scm b/src/runtime/cpoint.scm index b3b490c96..094ef78d8 100644 --- a/src/runtime/cpoint.scm +++ b/src/runtime/cpoint.scm @@ -55,7 +55,7 @@ USA. #| -;;; 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. diff --git a/src/runtime/gencache.scm b/src/runtime/dispatch-cache.scm similarity index 100% rename from src/runtime/gencache.scm rename to src/runtime/dispatch-cache.scm diff --git a/src/runtime/gentag.scm b/src/runtime/dispatch-tag.scm similarity index 100% rename from src/runtime/gentag.scm rename to src/runtime/dispatch-tag.scm diff --git a/src/runtime/dospth.scm b/src/runtime/dos-pathname.scm similarity index 100% rename from src/runtime/dospth.scm rename to src/runtime/dos-pathname.scm diff --git a/src/runtime/dosdir.scm b/src/runtime/dosdir.scm deleted file mode 100644 index 63be1d995..000000000 --- a/src/runtime/dosdir.scm +++ /dev/null @@ -1,323 +0,0 @@ -#| -*-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)) - -(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) pathnamepathname 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 - (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*)))))))))) - -(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))))) - - (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 diff --git a/src/runtime/dosprm.scm b/src/runtime/dosprm.scm deleted file mode 100644 index 4c23b0d80..000000000 --- a/src/runtime/dosprm.scm +++ /dev/null @@ -1,419 +0,0 @@ -#| -*-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)) - -(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."))))) - -(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)))) - -(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 - -(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!))) - -(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)))) - -(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 diff --git a/src/runtime/dosproc.scm b/src/runtime/dosproc.scm deleted file mode 100644 index a304269f8..000000000 --- a/src/runtime/dosproc.scm +++ /dev/null @@ -1,126 +0,0 @@ -#| -*-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)) - -(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 diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm index 3f38ceed0..1324bf90d 100644 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@ -38,11 +38,12 @@ USA. ("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)) @@ -52,21 +53,22 @@ USA. ("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)) @@ -77,32 +79,33 @@ USA. ("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)) @@ -114,16 +117,18 @@ USA. ("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)) @@ -148,8 +153,7 @@ USA. ("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)) @@ -168,26 +172,21 @@ USA. ("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)) diff --git a/src/runtime/uenvir.scm b/src/runtime/environment.scm similarity index 100% rename from src/runtime/uenvir.scm rename to src/runtime/environment.scm diff --git a/src/runtime/fileio.scm b/src/runtime/file-io.scm similarity index 100% rename from src/runtime/fileio.scm rename to src/runtime/file-io.scm diff --git a/src/runtime/genio.scm b/src/runtime/generic-io.scm similarity index 100% rename from src/runtime/genio.scm rename to src/runtime/generic-io.scm diff --git a/src/runtime/hashtb.scm b/src/runtime/hash-table.scm similarity index 100% rename from src/runtime/hashtb.scm rename to src/runtime/hash-table.scm diff --git a/src/runtime/httpio.scm b/src/runtime/http-io.scm similarity index 100% rename from src/runtime/httpio.scm rename to src/runtime/http-io.scm diff --git a/src/runtime/input.scm b/src/runtime/input-port.scm similarity index 100% rename from src/runtime/input.scm rename to src/runtime/input-port.scm diff --git a/src/runtime/intrpt.scm b/src/runtime/interrupt.scm similarity index 100% rename from src/runtime/intrpt.scm rename to src/runtime/interrupt.scm diff --git a/src/runtime/string.scm b/src/runtime/legacy-string.scm similarity index 95% rename from src/runtime/string.scm rename to src/runtime/legacy-string.scm index c04c55601..d72f130ef 100644 --- a/src/runtime/string.scm +++ b/src/runtime/legacy-string.scm @@ -25,7 +25,7 @@ USA. |# ;;;; Legacy Strings -;;; package: (runtime string) +;;; package: (runtime legacy-string) (declare (usual-integrations)) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 8b9e56e59..6fe5d69e8 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -359,17 +359,17 @@ USA. ("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)))) diff --git a/src/runtime/udata.scm b/src/runtime/microcode-data.scm similarity index 100% rename from src/runtime/udata.scm rename to src/runtime/microcode-data.scm diff --git a/src/runtime/uerror.scm b/src/runtime/microcode-errors.scm similarity index 100% rename from src/runtime/uerror.scm rename to src/runtime/microcode-errors.scm diff --git a/src/runtime/utabs.scm b/src/runtime/microcode-tables.scm similarity index 100% rename from src/runtime/utabs.scm rename to src/runtime/microcode-tables.scm diff --git a/src/runtime/output.scm b/src/runtime/output-port.scm similarity index 100% rename from src/runtime/output.scm rename to src/runtime/output-port.scm diff --git a/src/runtime/parse.scm b/src/runtime/parser.scm similarity index 100% rename from src/runtime/parse.scm rename to src/runtime/parser.scm diff --git a/src/runtime/pathnm.scm b/src/runtime/pathname.scm similarity index 100% rename from src/runtime/pathnm.scm rename to src/runtime/pathname.scm diff --git a/src/runtime/fixart.scm b/src/runtime/primitive-arithmetic.scm similarity index 98% rename from src/runtime/fixart.scm rename to src/runtime/primitive-arithmetic.scm index 03f996a2d..791841809 100644 --- a/src/runtime/fixart.scm +++ b/src/runtime/primitive-arithmetic.scm @@ -25,7 +25,7 @@ USA. |# ;;;; Low-level arithmetic -;;; package: (runtime fixnum-arithmetic) +;;; package: (runtime primitive-arithmetic) (declare (usual-integrations)) diff --git a/src/runtime/io.scm b/src/runtime/primitive-io.scm similarity index 100% rename from src/runtime/io.scm rename to src/runtime/primitive-io.scm diff --git a/src/runtime/uproc.scm b/src/runtime/procedure.scm similarity index 100% rename from src/runtime/uproc.scm rename to src/runtime/procedure.scm diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 6d2b8e73a..4bbef4bf6 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -221,10 +221,10 @@ USA. 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 () @@ -767,7 +767,7 @@ USA. uninterned-symbol?)) (define-package (runtime microcode-data) - (files "udata") + (files "microcode-data") (parent (runtime)) (export () compiled-code-address->block @@ -986,10 +986,10 @@ USA. 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 @@ -1001,7 +1001,7 @@ USA. (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) @@ -1420,7 +1420,7 @@ USA. 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) @@ -1468,7 +1468,7 @@ USA. 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) @@ -1540,7 +1540,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime console-i/o-port) - (files "ttyio") + (files "console-io") (parent (runtime)) (import (runtime primitive-io) tty-input-channel @@ -1794,7 +1794,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime procedure) - (files "uproc") + (files "procedure") (parent (runtime)) (export () %entity-extra @@ -1944,7 +1944,7 @@ USA. make-bundle-interface)) (define-package (runtime environment) - (files "uenvir") + (files "environment") (parent (runtime)) (export () compiled-procedure/environment @@ -2148,7 +2148,7 @@ USA. (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 @@ -2185,7 +2185,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime transcript) - (files "tscript") + (files "transcript") (parent (runtime)) (export () transcript-off @@ -2290,7 +2290,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime generic-i/o-port) - (files "genio") + (files "generic-io") (parent (runtime)) (export () binary->textual-port @@ -2375,7 +2375,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime hash-table) - (files "hashtb") + (files "hash-table") (parent (runtime)) (import (runtime population) add-to-population!/unsafe) @@ -2597,7 +2597,7 @@ USA. 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?) @@ -2725,7 +2725,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime input-port) - (files "input") + (files "input-port") (parent (runtime)) (export () deprecated:input-port make-eof-object @@ -2759,7 +2759,7 @@ USA. unread-char)) (define-package (runtime output-port) - (files "output") + (files "output-port") (parent (runtime)) (export () deprecated:output-port (flush-output flush-output-port) @@ -2797,7 +2797,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime interrupt-handler) - (files "intrpt") + (files "interrupt") (parent (runtime)) (export () event:console-resize) @@ -3138,7 +3138,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime microcode-errors) - (files "uerror") + (files "microcode-errors") (parent (runtime error-handler)) (export () condition-type:anomalous-microcode-error @@ -3163,7 +3163,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime microcode-tables) - (files "utabs") + (files "microcode-tables") (parent (runtime)) (export () microcode-id/compiled-code-type @@ -3358,7 +3358,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime parser) - (files "parse") + (files "parser") (parent (runtime)) (export () deprecated:parser (param:parser-canonicalize-symbols? param:parser-fold-case?) @@ -3387,7 +3387,7 @@ USA. parse-file-attributes-string)) (define-package (runtime pathname) - (files "pathnm") + (files "pathname") (parent (runtime)) (export () *default-pathname-defaults* @@ -3446,12 +3446,12 @@ USA. (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!))) @@ -3506,7 +3506,7 @@ USA. (initialization (initialize-package!))) (define-package (runtime primitive-io) - (files "io") + (files "primitive-io") (parent (runtime)) (export () all-dld-handles @@ -4414,7 +4414,7 @@ USA. (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!) @@ -5075,7 +5075,7 @@ USA. gdbm_writer)) (define-package (runtime tagged-dispatch) - (files "gentag" "gencache") + (files "dispatch-tag" "dispatch-cache") (parent (runtime)) (export () dispatch-metatag-constructor @@ -5490,7 +5490,7 @@ USA. write-http-headers)) (define-package (runtime http-i/o) - (files "httpio") + (files "http-io") (parent (runtime)) (export () http-message-body diff --git a/src/runtime/site.scm.dos b/src/runtime/site.scm.dos deleted file mode 100644 index 890d71724..000000000 --- a/src/runtime/site.scm.dos +++ /dev/null @@ -1,43 +0,0 @@ -#| -*-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 diff --git a/src/runtime/site.scm.unix b/src/runtime/site.scm.unix deleted file mode 100644 index 631139899..000000000 --- a/src/runtime/site.scm.unix +++ /dev/null @@ -1,66 +0,0 @@ -#| -*-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 diff --git a/src/runtime/stringio.scm b/src/runtime/string-io.scm similarity index 100% rename from src/runtime/stringio.scm rename to src/runtime/string-io.scm diff --git a/src/runtime/port.scm b/src/runtime/textual-port.scm similarity index 100% rename from src/runtime/port.scm rename to src/runtime/textual-port.scm diff --git a/src/runtime/tscript.scm b/src/runtime/transcript.scm similarity index 100% rename from src/runtime/tscript.scm rename to src/runtime/transcript.scm diff --git a/src/runtime/unxpth.scm b/src/runtime/unix-pathname.scm similarity index 100% rename from src/runtime/unxpth.scm rename to src/runtime/unix-pathname.scm -- 2.25.1