summaryrefslogtreecommitdiffstats
path: root/Init.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:24 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:24 -0800
commit1edcb9b62a1a520eddae8403c19d841c9b18737f (patch)
treebc0a43d9b3905726a76ed6f0528b54275f23d082 /Init.scm
parent5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 (diff)
downloadscm-1edcb9b62a1a520eddae8403c19d841c9b18737f.tar.gz
scm-1edcb9b62a1a520eddae8403c19d841c9b18737f.zip
Import Upstream version 5b3upstream/5b3
Diffstat (limited to 'Init.scm')
-rw-r--r--Init.scm184
1 files changed, 122 insertions, 62 deletions
diff --git a/Init.scm b/Init.scm
index 758c407..35575e9 100644
--- a/Init.scm
+++ b/Init.scm
@@ -42,7 +42,7 @@
;;; Author: Aubrey Jaffer.
(define (scheme-implementation-type) 'SCM)
-(define (scheme-implementation-version) "4e6")
+(define (scheme-implementation-version) "5b3")
;;; Temporary hack for compatability with older versions.
(define software-type
@@ -89,6 +89,15 @@
(if library-path (lambda () library-path)
implementation-vicinity)))
+(define home-vicinity
+ (let ((home (getenv "HOME")))
+ (and home
+ (case (software-type)
+ ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME
+ (if (not (char=? #\/ (string-ref home (+ -1 (string-length home)))))
+ (set! home (string-append home "/"))))))
+ (lambda () home)))
+
;;; Here for backward compatability
(define scheme-file-suffix
(case (software-type)
@@ -103,7 +112,6 @@
string-port source current-time)
*features*))
-(define slib:exit quit)
(define (exec-self)
(require 'i/o-extensions)
(execv (execpath) (program-arguments)))
@@ -179,13 +187,20 @@
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(read:array c port))
((#\!) (if (= 1 (line-number))
- (let skip () (if (eq? #\newline (peek-char port))
- (if #f #f)
- (begin (read-char port) (skip))))
+ (let skip ((metarg? #f))
+ (case (read-char port)
+ ((#\newline) (if metarg? (skip #t)))
+ ((#\\) (skip #t))
+ ((#\!) (if (not (and (eqv? #\# (peek-char port))
+ (read-char port)))
+ (skip metarg?)))
+ (else (skip metarg?))))
(barf)))
(else (barf))))
(define type 'type) ;for /bin/sh hack.
+(define : ':)
+(define !#(if #f #f)) ;for scsh hack.
;;;; Here are some Revised^2 Scheme functions:
(define 1+
@@ -202,15 +217,29 @@
(define >=? >=)
(define t #t)
(define nil #f)
-(define sequence begin)
-
-(set! apply
- (let ((apply:nconc-to-last apply:nconc-to-last)
- (@apply @apply))
- (lambda (fun . args) (@apply fun (apply:nconc-to-last args)))))
-(define call-with-current-continuation
- (let ((@call-with-current-continuation @call-with-current-continuation))
- (lambda (proc) (@call-with-current-continuation proc))))
+(cond ((defined? the-macro)
+ (define sequence (the-macro begin))
+ (set! apply
+ (let ((apply:nconc-to-last apply:nconc-to-last)
+ (@apply (the-macro @apply)))
+ (lambda (fun . args) (@apply fun (apply:nconc-to-last args)))))
+ (define call-with-current-continuation
+ (let ((@call-with-current-continuation
+ (the-macro @call-with-current-continuation)))
+ (lambda (proc) (@call-with-current-continuation proc)))))
+ (else
+ (define sequence begin)
+ (set! apply
+ (let ((apply:nconc-to-last apply:nconc-to-last)
+ (@apply @apply))
+ (lambda (fun . args) (@apply fun (apply:nconc-to-last args)))))
+ (define call-with-current-continuation
+ (let ((@call-with-current-continuation
+ @call-with-current-continuation))
+ (lambda (proc) (@call-with-current-continuation proc))))))
+(if (defined? copy-tree)
+ (define @copy-tree copy-tree)
+ (define copy-tree @copy-tree))
;;; VMS does something strange when output is sent to both
;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT.
@@ -292,6 +321,18 @@
(if (not (defined? force-output))
(define (force-output . a) #f))
+(define (warn . args)
+ (define cep (current-error-port))
+ (perror "WARN")
+ (errno 0)
+ (display "WARN: " cep)
+ (if (not (null? args))
+ (begin (display (car args) cep)
+ (for-each (lambda (x) (display #\ cep) (write x cep))
+ (cdr args))))
+ (newline cep)
+ (force-output cep))
+
(define (error . args)
(define cep (current-error-port))
(perror "ERROR")
@@ -306,12 +347,28 @@
(abort))
(define set-errno errno)
+(define slib:exit quit)
(define exit quit)
+(define (print . args)
+ (define result #f)
+ (for-each (lambda (x) (set! result x) (write x) (display #\ )) args)
+ (newline)
+ result)
+
(define (file-exists? str)
(let ((port (open-file str OPEN_READ)))
- (if port (begin (close-port port) #t)
- #f)))
+ (and port (close-port port) #t)))
+(define (file-readable? str)
+ (let ((port (open-file str OPEN_READ)))
+ (and port
+ (char-ready? port)
+ (do ((c (read-char port)
+ (and (char-ready? port) (read-char port)))
+ (i 0 (+ 1 i))
+ (l '() (cons c l)))
+ ((or (not c) (eof-object? c) (<= 2 i))
+ (if (null? l) #f (list->string (reverse l))))))))
(define difftime -)
(define offset-time +)
@@ -341,6 +398,7 @@
(define (identity x) x)
(define slib:error error)
+(define slib:warn warn)
(define slib:tab #\tab)
(define slib:form-feed #\page)
(define slib:eval eval)
@@ -373,21 +431,21 @@
(define hss (has-suffix? file (scheme-file-suffix)))
(load:pre file)
(or (and (defined? link:link) (not hss)
- (or (apply link:link file libs)
+ (or (let ((s2 (file-readable? file)))
+ (and s2 (not (equal? "#!" s2)) (apply link:link file libs)))
(and link:able-suffix
- (let ((fs (string-append file link:able-suffix)))
- (cond ((not (file-exists? fs)) #f)
- ((apply link:link fs libs) (set! filesuf fs) #t)
- (else #f))))))
+ (let* ((fs (string-append file link:able-suffix))
+ (fs2 (file-readable? fs)))
+ (and fs2 (apply link:link fs libs) (set! filesuf fs) #t)
+ ))))
(and (null? libs) (try-load file))
;;HERE is where the suffix gets specified
- (and (not hss)
- (begin (errno 0) ; clean up error from TRY-LOAD above
- (set! filesuf (string-append file (scheme-file-suffix)))
- (try-load filesuf)))
+ (and (not hss) (errno 0) ; clean up error from TRY-LOAD above
+ (set! filesuf (string-append file (scheme-file-suffix)))
+ (try-load filesuf))
(and (procedure? could-not-open) (could-not-open) #f)
- (let () (set! load:indent 0)
- (error "LOAD couldn't find file " file)))
+ (begin (set! load:indent 0)
+ (error "LOAD couldn't find file " file)))
(load:post filesuf))
(define load scm:load)
(define slib:load load)
@@ -453,7 +511,7 @@
(lambda (f)
(procedure->memoizing-macro
(lambda (exp env)
- (copy-tree (apply f (cdr exp)))))))
+ (@copy-tree (apply f (cdr exp)))))))
(define defmacro
(let ((defmacro-transformer
@@ -502,12 +560,6 @@
(evl o))
(set! *load-pathname* old-load-pathname)))))
-(define (print . args)
- (define result #f)
- (for-each (lambda (x) (set! result x) (write x) (display #\ )) args)
- (newline)
- result)
-
;;; Autoloads for SLIB procedures.
(define (tracef . args) (require 'trace) (apply tracef args))
@@ -529,10 +581,31 @@
(defmacro defvar (var val)
`(if (not (defined? ,var)) (define ,var ,val)))
+(define print-args
+ (procedure->syntax
+ (lambda (sexp env)
+ (let ((frame (and (not (null? env)) (car env))))
+ (cond ((not (null? (cdr sexp)))
+ (display "In")
+ (for-each (lambda (exp) (display #\ ) (display exp)) (cdr sexp))
+ (display ": ")))
+ (do ((vars (car frame) (cdr vars))
+ (vals (cdr frame) (cdr vals)))
+ ((not (pair? vars))
+ (cond ((not (null? vars))
+ (write vars)
+ (display " := ")
+ (write vals)))
+ (newline))
+ (write (car vars))
+ (display " = ")
+ (write (car vals))
+ (display "; "))))))
+
(cond
((defined? stack-trace)
- #+breakpoint-error;; remove this line to enable breakpointing on errors
+ #+breakpoint-error;; remove line to enable breakpointing on calls to ERROR
(define (error . args)
(define cep (current-error-port))
(perror "ERROR")
@@ -560,13 +633,11 @@
;;; ABS and MAGNITUDE can be the same.
(cond ((and (inexact? (string->number "0.0")) (not (defined? exp)))
- (if (defined? usr:lib)
- (if (usr:lib "m")
- (load (in-vicinity (implementation-vicinity) "Transcen")
- (usr:lib "m"))
- (load (in-vicinity (implementation-vicinity) "Transcen")))
- (load (in-vicinity (implementation-vicinity) "Transcen"
- (scheme-file-suffix))))
+ (or (and (defined? usr:lib)
+ (usr:lib "m")
+ (load (in-vicinity (implementation-vicinity) "Transcen")
+ (usr:lib "m")))
+ (load (in-vicinity (implementation-vicinity) "Transcen")))
(set! abs magnitude)))
(if (defined? array?)
@@ -606,23 +677,12 @@
;;; This loads the user's initialization file, or files named in
;;; program arguments.
-(or
- (eq? (software-type) 'THINKC)
- (member "-no-init-file" (program-arguments))
- (member "--no-init-file" (program-arguments))
- (try-load
- (in-vicinity
- (let ((home (getenv "HOME")))
- (if home
- (case (software-type)
- ((UNIX COHERENT)
- (if (char=? #\/ (string-ref home (+ -1 (string-length home))))
- home ;V7 unix has a / on HOME
- (string-append home "/")))
- (else home))
- (user-vicinity)))
- "ScmInit.scm"))
- (errno 0))
+(or (eq? (software-type) 'THINKC)
+ (member "-no-init-file" (program-arguments))
+ (member "--no-init-file" (program-arguments))
+ (try-load (in-vicinity (or (home-vicinity) (user-vicinity))
+ (string-append "ScmInit") (scheme-file-suffix)))
+ (errno 0))
(if (not (defined? *R4RS-macro*))
(define *R4RS-macro* #f))
@@ -704,7 +764,7 @@
(cond ((zero? (modulo i 4)) (newline cep) (display indent cep))))
(cdr arg-opts))
(display " [-- | -s | -] [file] [args...]" cep) (newline cep)
- (if success? (display success? cep) (exit #f)))
+ (if success? (display success? cep) (quit #f)))
;; -a int => ignore (handled by run_scm)
;; -c str => (eval str)
@@ -838,7 +898,7 @@ There is no warranty, to the extent permitted by law.
(set! *interactive* #t)))))
(cond ((not *interactive*) (quit))
- (*R4RS-macro*
+ ((and *R4RS-macro* (not (provided? 'macro)))
(require 'repl)
(require 'macro)
(let* ((oquit quit))
@@ -846,7 +906,7 @@ There is no warranty, to the extent permitted by law.
(set! exit quit)
(repl:top-level macro:eval)
(oquit))))
- ;;otherwise, fall into non-macro SCM repl.
+ ;;otherwise, fall into natural SCM repl.
)
(else
(begin (errno 0)