diff options
Diffstat (limited to 'Init.scm')
| -rw-r--r-- | Init.scm | 184 |
1 files changed, 122 insertions, 62 deletions
@@ -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) |