1;;; "slib.scm" configuration template of slib:features for Scheme -*-scheme-*- 2;;; Author: Shiro Kawai 3;;; based on the "Template.scm" by Aubrey Jaffer 4;;; 5;;; This code is in the public domain. 6 7;; SLIB module exports all symbols for compatibility. 8(define-module slib 9 (use srfi-0) 10 (use srfi-13) 11 (use srfi-111) ;; For make-exchanger 12 (extend util.record) ;; SLIB-compatible make-record-type 13 (use file.util) 14 (use gauche.uvector) ;; Used to implement 'byte' API 15 (use gauche.threads) ;; For make-exchanger 16 (export-all)) 17(select-module slib) 18 19;;@ (software-type) should be set to the generic operating system type. 20;;; unix, vms, macos, amiga and ms-dos are supported. 21 22(define (software-type) 23 (cond-expand 24 [gauche.windows 'ms-dos] 25 [else 'unix])) 26 27;;@ (scheme-implementation-type) should return the name of the scheme 28;;; implementation loading this file. 29(define (scheme-implementation-type) 'gauche) 30 31;;@ (scheme-implementation-home-page) should return a (string) URI 32;;; (Uniform Resource Identifier) for this scheme implementation's home 33;;; page; or false if there isn't one. 34(define (scheme-implementation-home-page) 35 "http://practical-scheme.net/gauche/") 36 37;;@ (scheme-implementation-version) should return a string describing 38;;; the version the scheme implementation loading this file. 39(define (scheme-implementation-version) (gauche-version)) 40 41;;@ (implementation-vicinity) should be defined to be the pathname of 42;;; the directory where any auxillary files to your Scheme 43;;; implementation reside. 44(define (implementation-vicinity) 45 (string-append (gauche-library-directory) "/")) 46 47;;@ (library-vicinity) should be defined to be the pathname of the 48;;; directory where files of Scheme library functions reside. 49(define library-vicinity 50 (let ((library-path 51 (or 52 ;; Use this getenv if your implementation supports it. 53 (and-let1 p (sys-getenv "SCHEME_LIBRARY_PATH") 54 (string-append p "/")) 55 ;; Use this path if your scheme does not support GETENV 56 ;; or if SCHEME_LIBRARY_PATH is not set. 57 (case (software-type) 58 ((unix) (regexp-replace "[^\/]$" 59 (with-module gauche.internal SLIB_DIR) 60 (^m #"~(m 0)/"))) 61 ((vms) "lib$scheme:") 62 ((ms-dos) "C:\\SLIB\\") 63 (else ""))))) 64 (lambda () library-path))) 65 66;;@ (home-vicinity) should return the vicinity of the user's HOME 67;;; directory, the directory which typically contains files which 68;;; customize a computer environment for a user. 69(define (home-vicinity) 70 (let ((home (or (sys-getenv "HOME") 71 (home-directory)))) 72 (and home 73 (case (software-type) 74 ((unix coherent ms-dos) ;V7 unix has a / on HOME 75 (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) 76 home 77 (string-append home "/"))) 78 (else home))))) 79 80;@ 81(define in-vicinity string-append) 82;@ 83(define (user-vicinity) 84 (case (software-type) 85 ((vms) "[.]") 86 (else ""))) 87 88(define *load-pathname* #f) 89;@ 90(define vicinity:suffix? 91 (let ((suffi 92 (case (software-type) 93 ((amiga) '(#\: #\/)) 94 ((macos thinkc) '(#\:)) 95 ((ms-dos windows atarist os/2) '(#\\ #\/)) 96 ((nosve) '(#\: #\.)) 97 ((unix coherent plan9) '(#\/)) 98 ((vms) '(#\: #\])) 99 (else 100 (slib:warn "require.scm" 'unknown 'software-type (software-type)) 101 "/")))) 102 (lambda (chr) (and (memv chr suffi) #t)))) 103;@ 104(define (pathname->vicinity pathname) 105 (let loop ((i (- (string-length pathname) 1))) 106 (cond ((negative? i) "") 107 ((vicinity:suffix? (string-ref pathname i)) 108 (substring pathname 0 (+ i 1))) 109 (else (loop (- i 1)))))) 110(define (program-vicinity) 111 (if *load-pathname* 112 (pathname->vicinity *load-pathname*) 113 (slib:error 'program-vicinity " called; use slib:load to load"))) 114;@ 115(define sub-vicinity 116 (case (software-type) 117 ((vms) (lambda 118 (vic name) 119 (let ((l (string-length vic))) 120 (if (or (zero? (string-length vic)) 121 (not (char=? #\] (string-ref vic (- l 1))))) 122 (string-append vic "[" name "]") 123 (string-append (substring vic 0 (- l 1)) 124 "." name "]"))))) 125 (else (let ((*vicinity-suffix* 126 (case (software-type) 127 ((nosve) ".") 128 ((macos thinkc) ":") 129 ((ms-dos windows atarist os/2) "\\") 130 ((unix coherent plan9 amiga) "/")))) 131 (lambda (vic name) 132 (string-append vic name *vicinity-suffix*)))))) 133;@ 134(define (make-vicinity <pathname>) <pathname>) 135;@ 136(define with-load-pathname 137 (let ((exchange 138 (lambda (new) 139 (let ((old *load-pathname*)) 140 (set! *load-pathname* new) 141 old)))) 142 (lambda (path thunk) 143 (let ((old #f)) 144 (dynamic-wind 145 (lambda () (set! old (exchange path))) 146 thunk 147 (lambda () (exchange old))))))) 148 149;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features 150;;; initially supported by this implementation. 151(define slib:features 152 '( 153 source ;can load scheme source files 154 ;(SLIB:LOAD-SOURCE "filename") 155;;; compiled ;can load compiled files 156 ;(SLIB:LOAD-COMPILED "filename") 157 vicinity 158 srfi-59 159 srfi-96 160 161 ;; Scheme report features 162 ;; R5RS-compliant implementations should provide all 9 features. 163 164 r5rs ;conforms to 165 eval ;R5RS two-argument eval 166 values ;R5RS multiple values 167 dynamic-wind ;R5RS dynamic-wind 168 macro ;R5RS high level macros 169 delay ;has DELAY and FORCE 170 multiarg-apply ;APPLY can take more than 2 args. 171 char-ready? 172 rev4-optional-procedures ;LIST-TAIL, STRING-COPY, 173 ;STRING-FILL!, and VECTOR-FILL! 174 175 ;; These four features are optional in both R4RS and R5RS 176 177 multiarg/and- ;/ and - can take more than 2 args. 178 rationalize 179;;; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF 180 with-file ;has WITH-INPUT-FROM-FILE and 181 ;WITH-OUTPUT-TO-FILE 182 183 r4rs ;conforms to 184 185 ieee-p1178 ;conforms to 186 187;;; r3rs ;conforms to 188 189;;; rev2-procedures ;SUBSTRING-MOVE-LEFT!, 190 ;SUBSTRING-MOVE-RIGHT!, 191 ;SUBSTRING-FILL!, 192 ;STRING-NULL?, APPEND!, 1+, 193 ;-1+, <?, <=?, =?, >?, >=? 194;;; object-hash ;has OBJECT-HASH 195 ;; NB: Gauche's object-hash is different from SLIB wants, which 196 ;; is Gauche's eqv-hash. Providing it in the name of object-hash 197 ;; would be confusing, so we don't provide this. 198 199 full-continuation ;can return multiple times 200 ieee-floating-point ;conforms to IEEE Standard 754-1985 201 ;IEEE Standard for Binary 202 ;Floating-Point Arithmetic. 203 204 ;; Other common features 205 206 ;; NB: we turned off srfi here, since if this is on, slib tries 207 ;; to import all available srfis, including srfi-29, which defines 208 ;; incompatible 'format'. 209 srfi-0 ;srfi-0, COND-EXPAND finds all srfi-* 210;;; sicp ;runs code from Structure and 211 ;Interpretation of Computer 212 ;Programs by Abelson and Sussman. 213 defmacro ;has Common Lisp DEFMACRO 214;;; syntax-case ;has syncase:eval and syncase:load 215 record ;has user defined data structures 216 string-port ;has CALL-WITH-INPUT-STRING and 217 ;CALL-WITH-OUTPUT-STRING 218 sort 219;;; pretty-print 220 object->string 221;;; format ;Common-lisp output formatting 222;;; trace ;has macros: TRACE and UNTRACE 223;;; compiler ;has (COMPILER) 224;;; ed ;(ED) is editor 225 system ;posix (system <string>) 226 getenv ;posix (getenv <string>) 227 program-arguments ;returns list of strings (argv) 228 current-time ;returns time in seconds since 1/1/1970 229 230 ;; Implementation Specific features 231 byte ;byte string manipulation 232 )) 233 234;;@ (FILE-POSITION <port> . <k>) 235(define (file-position . args) #f) 236 237;;@ (OUTPUT-PORT-WIDTH <port>) 238(define (output-port-width . arg) 79) 239 240;;@ (OUTPUT-PORT-HEIGHT <port>) 241(define (output-port-height . arg) 24) 242 243;;@ (CURRENT-ERROR-PORT) - Gauche has it 244;(define current-error-port 245; (let ((port (current-output-port))) 246; (lambda () port))) 247 248;;@ (TMPNAM) makes a temporary file name. 249(define tmpnam sys-tmpnam) 250 251;;@ SYSTEM 252(define system sys-system) 253 254;;@ GETENV 255(define getenv sys-getenv) 256 257;;@ (FILE-EXISTS? <string>) 258; Gauche has this 259 260;;@ (DELETE-FILE <string>) 261(define delete-file (with-module file.util delete-file)) 262 263;;@ FORCE-OUTPUT flushes any pending output on optional arg output port 264;;; use this definition if your system doesn't have such a procedure. 265(define force-output flush) 266 267;;@ CURRENT-TIME 268(define current-time sys-time) 269 270;;@ PROGRAM-ARGUMENTS 271(define (program-arguments) (with-module user *argv*)) 272 273;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string 274;;; port versions of CALL-WITH-*PUT-FILE. 275 276;;@ "rationalize" adjunct procedures. 277(define (find-ratio x e) 278 (let ((rat (rationalize x e))) 279 (list (numerator rat) (denominator rat)))) 280(define (find-ratio-between x y) 281 (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) 282 283;;@ CHAR-CODE-LIMIT is one greater than the largest integer which can 284;;; be returned by CHAR->INTEGER. 285(define char-code-limit (+ *char-code-max* 1)) 286 287;;@ MOST-POSITIVE-FIXNUM is used in modular.scm 288(define most-positive-fixnum (greatest-fixnum)) 289 290;;@ Return argument 291;(define (identity x) x) ; Gauche has this. 292 293;;@ SLIB:EVAL is single argument eval using the top-level (user) environment. 294(define (slib:eval expr) (eval expr (interaction-environment))) 295 296;; If your implementation provides R4RS macros: 297(define macro:eval slib:eval) 298;;@ %SLIB-LOAD loads file in slib module. 299(define (%slib-load file) 300 (load file :environment (current-module))) 301(define macro:load %slib-load) 302 303(define-syntax defmacro 304 (syntax-rules () 305 ((_ name params . body) (define-macro (name . params) . body)))) 306 307;; Gauche has these 308; macroexpand-1 309; macroexpand 310;@ 311(define (gentemp) (gensym "slib:G")) 312 313(define base:eval slib:eval) 314;@ 315(define (defmacro:eval x) (eval x (current-module))) 316(define (macro:expand x) (macroexpand x)) 317;(define (defmacro:expand* x) 318; (require 'defmacroexpand) (apply defmacro:expand* x '())) 319;@ 320(define defmacro:load %slib-load) 321;; slib:eval-load definition moved to "require.scm" 322;@ 323(define slib:warn 324 (lambda args 325 (let ((cep (current-error-port))) 326 ;;(if (provided? 'trace) (print-call-stack cep)) 327 (display "Warn: " cep) 328 (for-each (lambda (x) (display #\space cep) (write x cep)) args) 329 (newline cep)))) 330 331;;@ define an error procedure for the library 332(define slib:error error) 333;@ 334(define (make-exchanger obj) 335 (let1 a (atom (box obj)) 336 (lambda (new) (atomic a (^[b] (begin0 (unbox b) (set-box! b new))))))) 337(define (open-file filename modes) 338 (case modes 339 ((r rb) (open-input-file filename)) 340 ((w wb) (open-output-file filename)) 341 (else (slib:error 'open-file 'mode? modes)))) 342(define (port? obj) (or (input-port? obj) (output-port? obj))) 343(define (call-with-open-ports . ports) 344 (define proc (car ports)) 345 (cond ((procedure? proc) (set! ports (cdr ports))) 346 (else (set! ports (reverse ports)) 347 (set! proc (car ports)) 348 (set! ports (reverse (cdr ports))))) 349 (let ((ans (apply proc ports))) 350 (for-each close-port ports) 351 ans)) 352(define (close-port port) 353 (cond ((input-port? port) 354 (close-input-port port) 355 (if (output-port? port) (close-output-port port))) 356 ((output-port? port) (close-output-port port)) 357 (else (slib:error 'close-port 'port? port)))) 358;@ 359(define (browse-url url) 360 (define (try cmd end) (zero? (system (string-append cmd url end)))) 361 (or (try "xdg-open '" "' &") 362 (try "firefox '" "' &"))) 363 364;@ 365(define object->string write-to-string) 366 367;;@ define these as appropriate for your system. 368(define slib:tab (integer->char 9)) 369(define slib:form-feed (integer->char 12)) 370 371;;@ Support for older versions of Scheme. Not enough code for its own file. 372;(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) ; Gauche has this. 373(define t #t) 374(define nil #f) 375 376;;; byte string operators. SLIB's byte module uses slib array. 377;;; It's more efficient to use u8vector in Gauche. 378 379(define (byte-ref s k) (u8vector-ref s k)) 380(define (byte-set! s k b) (u8vector-set! s k b)) 381(define make-bytes make-u8vector) 382(define (bytes-length s) (u8vector-length s)) 383(define bytes u8vector) 384(define bytes->list u8vector->list) 385(define list->bytes list->u8vector) 386(define bytes->string u8vector->string) 387(define string->bytes string->u8vector) 388(define bytes-copy u8vector-copy) 389;; write-byte - Gauche has this 390;; read-byte - Gauche has this 391 392;;@ Define these if your implementation's syntax can support it and if 393;;; they are not already defined. 394(define (1+ n) (+ n 1)) 395(define (-1+ n) (+ n -1)) 396(define 1- -1+) 397 398;;@ Define SLIB:EXIT to be the implementation procedure to exit or 399;;; return if exiting not supported. 400(define slib:exit exit) 401 402;;@ Here for backward compatability 403(define scheme-file-suffix 404 (let ((suffix (case (software-type) 405 ((nosve) "_scm") 406 (else ".scm")))) 407 (lambda () suffix))) 408 409;;@ (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever 410;;; suffix all the module files in SLIB have. See feature 'SOURCE. 411(define (slib:load-source f) (load (string-append f ".scm"))) 412 413;;@ (SLIB:LOAD-COMPILED "foo") should load the file that was produced 414;;; by compiling "foo.scm" if this implementation can compile files. 415;;; See feature 'COMPILED. 416(define slib:load-compiled load) 417 418;;@ At this point SLIB:LOAD must be able to load SLIB files. 419(define slib:load load) 420 421;; We have to provide slib-related srfis now, since slib's require.scm 422;; tries to load all available srfis. 423(provide "srfi-59") 424(define-module srfi-59) 425(provide "srfi-96") 426(define-module srfi-96) 427 428;; [SK] Emit comprehensive message in case we can't find SLIB 429;(slib:load (in-vicinity (library-vicinity) "require")) 430(unless (load (in-vicinity (library-vicinity) "require") 431 :error-if-not-found #f) 432 (error #"Couldn't load SLIB's require.scm in `~(library-vicinity)'. \ 433 Either SLIB is not installed, or it is installed in a different \ 434 location. Try setting the environment variable \ 435 SCHEME_LIBRARY_PATH to point to the SLIB directory; or you can \ 436 reconfigure Gauche with --with-slib option and reinstall." )) 437 438;;; A trick to make require work both on Gauche files and slib files. 439;;; The hint is taken from STk. 440 441(define-macro (require feature) ;redefine 442 (if (string? feature) 443 `',(%require feature) ;gauche version 444 `(slib:require ,feature))) ;slib version 445 446(define (provide feature) 447 (if (string? feature) 448 (with-module gauche (provide feature)) ;gauche version 449 (slib:provide feature))) ;slib version 450 451(define (provided? feature) 452 (if (string? feature) 453 (with-module gauche (provided? feature)) ;gauche version 454 (slib:provided? feature))) ;slib version 455