summaryrefslogtreecommitdiffstats
path: root/guile.init
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:36 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:36 -0800
commit5bea21e81ed516440e34e480f2c33ca41aa8c597 (patch)
tree653ace1b8fe0a9916d861d35ff8f611b46c80d37 /guile.init
parent237c6e380aebdcbc70bd1c9ecf7d3f6effca2752 (diff)
downloadslib-5bea21e81ed516440e34e480f2c33ca41aa8c597.tar.gz
slib-5bea21e81ed516440e34e480f2c33ca41aa8c597.zip
Import Upstream version 3a4upstream/3a4
Diffstat (limited to 'guile.init')
-rw-r--r--guile.init114
1 files changed, 63 insertions, 51 deletions
diff --git a/guile.init b/guile.init
index 76f1f0e..9cf6ed4 100644
--- a/guile.init
+++ b/guile.init
@@ -6,7 +6,6 @@
(if (string<? (version) "1.6")
(define-module (ice-9 slib))) ; :no-backtrace
(define slib-module (current-module))
-(define (defined? symbol) (module-defined? slib-module symbol))
(define base:define define)
(define define
@@ -59,6 +58,7 @@
(and (defined? 'getenv) (getenv "SCHEME_LIBRARY_PATH"))
;; Use this path if your scheme does not support GETENV
;; or if SCHEME_LIBRARY_PATH is not set.
+ "/usr/lib/slib/"
(in-vicinity (implementation-vicinity) "slib/"))))
(lambda () library-path)))
@@ -75,8 +75,6 @@
(string-append home "/")))
(else home)))))
;@
-(define in-vicinity string-append)
-;@
(define (user-vicinity)
(case (software-type)
((vms) "[.]")
@@ -144,9 +142,9 @@
thunk
(lambda () (exchange old))))))
-;;@ *FEATURES* is a list of symbols naming the (SLIB) features
+;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features
;;; initially supported by this implementation.
-(define *features*
+(define slib:features
(append
'(
source ;can load scheme source files
@@ -239,9 +237,7 @@
(if (defined? 'char-ready?)
'(char-ready?)
- '())
-
- *features*))
+ '())))
;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)
@@ -261,13 +257,13 @@
;; "status:stop-sig" shouldn't arise here, since system shouldn't be
;; calling waitpid with WUNTRACED, but allow for it anyway, just in
;; case.
-(define system
- (let ((guile-core-system system))
- (lambda (str)
- (define st (guile-core-system str))
- (or (status:exit-val st)
- (+ 128 (or (status:term-sig st)
- (status:stop-sig st)))))))
+(set! system
+ (let ((guile-core-system system))
+ (lambda (str)
+ (define st (guile-core-system str))
+ (or (status:exit-val st)
+ (+ 128 (or (status:term-sig st)
+ (status:stop-sig st)))))))
;;; for line-i/o
(use-modules (ice-9 popen))
@@ -279,13 +275,21 @@
(status:term-sig status)
(status:stop-sig status))
(if (eof-object? line) "" line)))))
-
-(define delete-file
- (let ((guile-core-delete-file delete-file))
- (lambda (filename)
- (catch 'system-error
- (lambda () (guile-core-delete-file filename) #t)
- (lambda args #f)))))
+;; rdelim was loaded by default in guile 1.6, but not in 1.8
+;; load it to get read-line, read-line! and write-line,
+;; and re-export them for the benefit of loading this file from (ice-9 slib)
+(cond ((string>=? (scheme-implementation-version) "1.8")
+ (use-modules (ice-9 rdelim))
+ (re-export read-line)
+ (re-export read-line!)
+ (re-export write-line)))
+
+(set! delete-file
+ (let ((guile-core-delete-file delete-file))
+ (lambda (filename)
+ (catch 'system-error
+ (lambda () (guile-core-delete-file filename) #t)
+ (lambda args #f)))))
;;; FORCE-OUTPUT flushes any pending output on optional arg output port
;;; use this definition if your system doesn't have such a procedure.
@@ -296,14 +300,13 @@
(define (make-exchanger obj)
(lambda (rep) (let ((old obj)) (set! obj rep) old)))
-(define open-file
- (let ((guile-core-open-file open-file))
- (lambda (filename modes)
- (guile-core-open-file filename
- (if (symbol? modes)
- (symbol->string modes)
- modes)))))
-(define (port? obj) (or (input-port? obj) (output-port? obj)))
+(set! open-file
+ (let ((guile-core-open-file open-file))
+ (lambda (filename modes)
+ (guile-core-open-file filename
+ (if (symbol? modes)
+ (symbol->string modes)
+ modes)))))
(define (call-with-open-ports . ports)
(define proc (car ports))
(cond ((procedure? proc) (set! ports (cdr ports)))
@@ -314,6 +317,18 @@
(for-each close-port ports)
ans))
+(if (not (defined? 'browse-url))
+ ;; Nothing special to do for this, so straight from
+ ;; Template.scm. Maybe "sensible-browser" for a debian
+ ;; system would be worth trying too (and would be good on a
+ ;; tty).
+ (define (browse-url url)
+ (define (try cmd end) (zero? (system (string-append cmd url end))))
+ (or (try "netscape-remote -remote 'openURL(" ")'")
+ (try "netscape -remote 'openURL(" ")'")
+ (try "netscape '" "'&")
+ (try "netscape '" "'"))))
+
;;; "rationalize" adjunct procedures.
;;(define (find-ratio x e)
;; (let ((rat (rationalize x e)))
@@ -323,14 +338,13 @@
;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
-;;(define char-code-limit 256)
+;; In Guile-1.8.0: (string>? (string #\000) (string #\200)) ==> #t
+(if (string=? (version) "1.8.0")
+ (define char-code-limit 128))
;;; MOST-POSITIVE-FIXNUM is used in modular.scm
;;(define most-positive-fixnum #x0FFFFFFF)
-;;; Return argument
-(define (identity x) x)
-
;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval
(if (string<? (scheme-implementation-version) "1.5")
@@ -475,7 +489,7 @@
(define bitwise-xor logxor)
(define bitwise-and logand)
(define bitwise-not lognot)
-(define bit-count logcount)
+;;(define bit-count logcount)
(define bit-set? logbit?)
(define any-bits-set? logtest)
(define first-set-bit log2-binary-factors)
@@ -493,19 +507,24 @@
(array-shape array)))))
;; DIMENSIONS->UNIFORM-ARRAY and list->uniform-array in Guile-1.6.4
;; cannot make empty arrays.
-(define (make-array prot . args)
- (if (array-null? prot)
- (dimensions->uniform-array args (array-prototype prot))
- (dimensions->uniform-array args (array-prototype prot)
- (apply array-ref prot
- (map car (array-shape prot))))))
+(set! make-array
+ (lambda (prot . args)
+ (if (array-null? prot)
+ (dimensions->uniform-array args (array-prototype prot))
+ (dimensions->uniform-array args (array-prototype prot)
+ (apply array-ref prot
+ (map car (array-shape prot)))))))
(define create-array make-array)
(define (make-uniform-wrapper prot)
(if (string? prot) (set! prot (string->number prot)))
(if prot
- (lambda opt (if (null? opt)
- (list->uniform-array 1 prot (list prot))
- (list->uniform-array 0 prot opt)))
+ (if (string<? (version) "1.8")
+ (lambda opt (if (null? opt)
+ (list->uniform-array 1 prot (list prot))
+ (list->uniform-array 0 prot opt)))
+ (lambda opt (if (null? opt)
+ (list->uniform-array 1 prot (list prot))
+ (list->uniform-array 0 prot (car opt)))))
vector))
(define ac64 (make-uniform-wrapper "+i"))
(define ac32 ac64)
@@ -586,16 +605,9 @@
;;; Support for older versions of Scheme. Not enough code for its own file.
;;(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))
-;;; Guile has nil and t as self-sets
(define t #t)
(define nil #f)
-;;; Define these if your implementation's syntax can support it and if
-;;; they are not already defined.
-(define (1+ n) (+ n 1))
-(define (-1+ n) (+ n -1))
-(define 1- -1+)
-
;;; rev2-procedures
(define <? <)
(define <=? <=)