"Fossies" - the Fresh Open Source Software Archive

Member "slib-3b6/guile-2.init" (18 Jul 2018, 21161 Bytes) of package /linux/privat/slib-3b6.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "guile-2.init": 3b5_vs_3b6.

    1 ;"guile.init" Configuration file for SLIB for Guile	-*-scheme-*-
    2 ;;; Author: Aubrey Jaffer
    3 ;;; Author: Andy Wingo
    4 ;;;
    5 ;;; This code is in the public domain.
    6 
    7 (cond-expand
    8  (guile-2)
    9  (else
   10   (error "Guile 2.0 or later is required.")))
   11 
   12 (define-module (ice-9 slib)
   13   #:use-module ((ice-9 popen) #:select (open-input-pipe close-pipe))
   14   #:use-module ((ice-9 rdelim) #:select (read-line read-line! write-line))
   15   #:re-export (read-line read-line! write-line)
   16   #:export (<=?
   17             <?
   18             =?
   19             >=?
   20             >?
   21             A:bool
   22             A:fixN16b
   23             A:fixN32b
   24             A:fixN64b
   25             A:fixN8b
   26             A:fixZ16b
   27             A:fixZ32b
   28             A:fixZ64b
   29             A:fixZ8b
   30             A:floC128b
   31             A:floC16b
   32             A:floC32b
   33             A:floC64b
   34             A:floR128b
   35             A:floR128d
   36             A:floR16b
   37             A:floR32b
   38             A:floR32d
   39             A:floR64b
   40             A:floR64d
   41             a:bool
   42             a:fixn16b
   43             a:fixn32b
   44             a:fixn64b
   45             a:fixn8b
   46             a:fixz16b
   47             a:fixz32b
   48             a:fixz64b
   49             a:fixz8b
   50             a:floc128b
   51             a:floc16b
   52             a:floc32b
   53             a:floc64b
   54             a:flor128b
   55             a:flor128d
   56             a:flor16b
   57             a:flor32b
   58             a:flor32d
   59             a:flor64b
   60             a:flor64d
   61             any-bits-set?
   62             arithmetic-shift
   63             array-indexes
   64             array-null?
   65             array:copy!
   66             ;; ac32
   67             ;; ac64
   68             ;; ar32
   69             ;; ar64
   70             ;; as16
   71             ;; as32
   72             ;; as64
   73             ;; as8
   74             ;; at1
   75             ;; au16
   76             ;; au32
   77             ;; au64
   78             ;; au8
   79             bit-field
   80             bit-reverse
   81             bit-set?
   82             bitwise-and
   83             bitwise-if
   84             bitwise-ior
   85             bitwise-merge
   86             bitwise-not
   87             bitwise-xor
   88             booleans->integer
   89             browse-url
   90             call-with-open-ports
   91             copy-bit
   92             copy-bit-field
   93             create-array
   94             ;;define
   95             defmacro:eval
   96             defmacro:expand*
   97             defmacro:load
   98             ;;delete-file
   99             difftime
  100             ;;file-position
  101             first-set-bit
  102             gentemp
  103             home-vicinity
  104             implementation-vicinity
  105             integer->list
  106             library-vicinity
  107             list->array
  108             list->integer
  109             log2-binary-factors
  110             logical:ash
  111             logical:bit-extract
  112             logical:integer-expt
  113             logical:integer-length
  114             ;;logical:ipow-by-squaring
  115             logical:logand
  116             logical:logcount
  117             logical:logior
  118             logical:lognot
  119             logical:logxor
  120             macro:eval
  121             macro:load
  122             make-array
  123             make-exchanger
  124             make-random-state
  125             ;;make-uniform-wrapper
  126             make-vicinity
  127             ;; nil
  128             offset-time
  129             ;;open-file
  130             output-port-height
  131             output-port-width
  132             pathname->vicinity
  133             program-vicinity
  134             random:chunk
  135             reverse-bit-field
  136             rotate-bit-field
  137             scheme-implementation-home-page
  138             scheme-implementation-type
  139             scheme-implementation-version
  140             ;; slib-module
  141             slib:error
  142             slib:eval
  143             slib:eval-load
  144             slib:exit
  145             ;; slib:features
  146             slib:form-feed
  147             slib:load
  148             slib:load-compiled
  149             slib:load-source
  150             slib:tab
  151             slib:warn
  152             software-type
  153             sub-vicinity
  154             ;;system
  155             system->line
  156             ;; t
  157             user-vicinity
  158             vector->array
  159             ;; vicinity:suffix?
  160             ;; with-load-pathname
  161             )
  162   #:replace (file-position
  163              system
  164              open-file
  165              delete-file
  166              char-code-limit
  167              scheme-file-suffix
  168              gentemp
  169              make-array
  170              list->array
  171              provide
  172              provided?))
  173 
  174 (module-export-all! (current-module))
  175 
  176 ;;; (software-type) should be set to the generic operating system type.
  177 ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported.
  178 (define (software-type) 'unix)
  179 
  180 ;;; (scheme-implementation-type) should return the name of the scheme
  181 ;;; implementation loading this file.
  182 (define (scheme-implementation-type) 'guile)
  183 
  184 ;;; (scheme-implementation-home-page) should return a (string) URI
  185 ;;; (Uniform Resource Identifier) for this scheme implementation's home
  186 ;;; page; or false if there isn't one.
  187 (define (scheme-implementation-home-page)
  188   "http://www.gnu.org/software/guile/")
  189 
  190 ;;; (scheme-implementation-version) should return a string describing
  191 ;;; the version the scheme implementation loading this file.
  192 (define scheme-implementation-version version)
  193 
  194 ;;; (implementation-vicinity) should be defined to be the pathname of
  195 ;;; the directory where any auxillary files to your Scheme
  196 ;;; implementation reside.
  197 (define implementation-vicinity
  198   (cond ((getenv "GUILE_IMPLEMENTATION_PATH")
  199 	 => (lambda (path) (lambda () path)))
  200 	(else %site-dir)))
  201 
  202 ;;; (library-vicinity) should be defined to be the pathname of the
  203 ;;; directory where files of Scheme library functions reside.
  204 (define library-vicinity
  205   (let ((library-path
  206 	 (or (getenv "SCHEME_LIBRARY_PATH")
  207              (string-append (canonicalize-path (dirname (current-filename)))
  208                             "/")
  209              ;; A fallback; normally shouldn't be reached.
  210              "/usr/share/slib/")))
  211     (lambda () library-path)))
  212 
  213 ;;; (home-vicinity) should return the vicinity of the user's HOME
  214 ;;; directory, the directory which typically contains files which
  215 ;;; customize a computer environment for a user.
  216 (define (home-vicinity)
  217   (let ((home (or (getenv "HOME")
  218                   (false-if-exception
  219                    (passwd:dir (getpwnam (cuserid)))))))
  220     (and home
  221 	 (if (eqv? #\/ (string-ref home (+ -1 (string-length home))))
  222              home
  223              (string-append home "/")))))
  224 ;@
  225 (define (user-vicinity)
  226   "")
  227 ;@
  228 (define vicinity:suffix?
  229   (case (software-type)
  230     ((ms-dos windows)
  231      (lambda (chr) (memv chr '(#\/ #\\))))
  232     (else
  233      (lambda (chr) (eqv? chr #\/)))))
  234 ;@
  235 (define (pathname->vicinity pathname)
  236   (let loop ((i (- (string-length pathname) 1)))
  237     (cond ((negative? i) "")
  238 	  ((vicinity:suffix? (string-ref pathname i))
  239 	   (substring pathname 0 (+ i 1)))
  240 	  (else (loop (- i 1))))))
  241 ;@
  242 (define program-vicinity
  243   (make-parameter (getcwd) pathname->vicinity))
  244 ;@
  245 (define sub-vicinity
  246   (let ((*vicinity-suffix*
  247          (case (software-type)
  248            ((ms-dos windows atarist os/2) "\\")
  249            ((unix coherent plan9 amiga) "/"))))
  250     (lambda (vic name)
  251       (string-append vic name *vicinity-suffix*))))
  252 ;@
  253 (define (make-vicinity <pathname>) <pathname>)
  254 ;@
  255 (define (with-load-pathname path thunk)
  256   (parameterize ((program-vicinity path))
  257     (thunk)))
  258 
  259 ;;@ SLIB:FEATURES is a list of symbols naming the (SLIB) features
  260 ;;; initially supported by this implementation.
  261 (define slib:features
  262   '(source				;can load scheme source files
  263 					;(SLIB:LOAD-SOURCE "filename")
  264     compiled				;can load compiled files
  265 					;(SLIB:LOAD-COMPILED "filename")
  266     vicinity
  267     srfi-59
  268     srfi-96
  269 
  270     ;; Scheme report features
  271     ;; R5RS-compliant implementations should provide all 9 features.
  272 
  273     r5rs				;conforms to
  274     eval				;R5RS two-argument eval
  275     values				;R5RS multiple values
  276     dynamic-wind			;R5RS dynamic-wind
  277     macro				;R5RS high level macros
  278     delay                              ;has DELAY and FORCE
  279     multiarg-apply                     ;APPLY can take more than 2 args.
  280     char-ready?
  281     rev4-optional-procedures            ;LIST-TAIL, STRING-COPY,
  282 					;STRING-FILL!, and VECTOR-FILL!
  283 
  284     ;; These four features are optional in both R4RS and R5RS
  285 
  286     multiarg/and-                    ;/ and - can take more than 2 args.
  287     rationalize
  288 ;;;	transcript			;TRANSCRIPT-ON and TRANSCRIPT-OFF
  289     with-file                           ;has WITH-INPUT-FROM-FILE and
  290 					;WITH-OUTPUT-TO-FILE
  291 
  292 ;;;	r4rs				;conforms to
  293 
  294 ;;;	ieee-p1178			;conforms to
  295 
  296 ;;;	r3rs				;conforms to
  297 
  298     rev2-procedures			;SUBSTRING-MOVE-LEFT!,
  299 					;SUBSTRING-MOVE-RIGHT!,
  300 					;SUBSTRING-FILL!,
  301 					;STRING-NULL?, APPEND!, 1+,
  302 					;-1+, <?, <=?, =?, >?, >=?
  303 ;;;	object-hash			;has OBJECT-HASH
  304     hash				;HASH, HASHV, HASHQ
  305 
  306     full-continuation                   ;can return multiple times
  307     ieee-floating-point			;conforms to IEEE Standard 754-1985
  308 					;IEEE Standard for Binary
  309 					;Floating-Point Arithmetic.
  310 
  311     ;; Other common features
  312 
  313     srfi-0                         ;srfi-0, COND-EXPAND finds all srfi-*
  314 ;;;	sicp				;runs code from Structure and
  315 					;Interpretation of Computer
  316 					;Programs by Abelson and Sussman.
  317     defmacro                            ;has Common Lisp DEFMACRO
  318 ;;;	record				;has user defined data structures
  319     string-port                         ;has CALL-WITH-INPUT-STRING and
  320 					;CALL-WITH-OUTPUT-STRING
  321     line-i/o
  322 ;;;	sort
  323 ;;;	pretty-print
  324 ;;;	object->string
  325 ;;;	format				;Common-lisp output formatting
  326 ;;;	trace				;has macros: TRACE and UNTRACE
  327 ;;;	compiler			;has (COMPILER)
  328 ;;;	ed				;(ED) is editor
  329     system				;posix (system <string>)
  330     getenv				;posix (getenv <string>)
  331     program-arguments			;returns list of strings (argv)
  332     current-time			;returns time in seconds since 1/1/1970
  333 
  334     ;; Implementation Specific features
  335 
  336     logical
  337     random				;Random numbers
  338 
  339     array
  340     array-for-each
  341     ))
  342 
  343 ;;@ (FILE-POSITION <port> . <k>)
  344 (define* (file-position port #:optional k)
  345   (if k
  346       (seek port k SEEK_SET)
  347       (ftell port)))
  348 
  349 ;;; (OUTPUT-PORT-WIDTH <port>)
  350 (define (output-port-width . arg) 79)
  351 
  352 ;;; (OUTPUT-PORT-HEIGHT <port>)
  353 (define (output-port-height . arg) 24)
  354 
  355 ;; If the program is killed by a signal, /bin/sh normally gives an
  356 ;; exit code of 128+signum.  If /bin/sh itself is killed by a signal
  357 ;; then we do the same 128+signum here.
  358 ;;
  359 ;; "status:stop-sig" shouldn't arise here, since system shouldn't be
  360 ;; calling waitpid with WUNTRACED, but allow for it anyway, just in
  361 ;; case.
  362 (define (system str)
  363   (define st ((@ (guile) system) str))
  364   (or (status:exit-val st)
  365       (+ 128 (or (status:term-sig st)
  366                  (status:stop-sig st)))))
  367 
  368 ;;; for line-i/o
  369 (define* (system->line command #:optional tmp)
  370   ;; TMP is the name of a temporary file, and is unused because we use
  371   ;; pipes.
  372   (let ((ipip (open-input-pipe command)))
  373     (define line (read-line ipip))
  374     (let ((status (close-pipe ipip)))
  375       (and (or (eqv? 0 (status:exit-val status))
  376 	       (status:term-sig status)
  377 	       (status:stop-sig status))
  378 	   (if (eof-object? line) "" line)))))
  379 
  380 (define (delete-file filename)
  381   (false-if-exception
  382    ((@ (guile) delete-file) filename)))
  383 
  384 (define (make-exchanger obj)
  385   (lambda (rep) (let ((old obj)) (set! obj rep) old)))
  386 (define (open-file filename modes)
  387   ((@ (guile) open-file)
  388    filename
  389    (if (symbol? modes)
  390        (symbol->string modes)
  391        modes)))
  392 ;; This has to be done after the definition so that the original
  393 ;; binding will still be visible during the definition.
  394 (if (string>=? (scheme-implementation-version) "1.8")
  395     (module-replace! (current-module) '(open-file)))
  396 
  397 (define (call-with-open-ports . ports)
  398   (define proc (car ports))
  399   (cond ((procedure? proc) (set! ports (cdr ports)))
  400 	(else (set! ports (reverse ports))
  401 	      (set! proc (car ports))
  402 	      (set! ports (reverse (cdr ports)))))
  403   (let ((ans (apply proc ports)))
  404     (for-each close-port ports)
  405     ans))
  406 
  407 ;; Nothing special to do for this, so straight from
  408 ;; Template.scm.  Maybe "sensible-browser" for a debian
  409 ;; system would be worth trying too (and would be good on a
  410 ;; tty).
  411 (define (browse-url url)
  412       (define (try cmd end) (zero? (system (string-append cmd url end))))
  413       (or (try "netscape-remote -remote 'openURL(" ")'")
  414 	  (try "netscape -remote 'openURL(" ")'")
  415 	  (try "netscape '" "'&")
  416 	  (try "netscape '" "'")))
  417 
  418 ;;; "rationalize" adjunct procedures.
  419 ;;(define (find-ratio x e)
  420 ;;  (let ((rat (rationalize x e)))
  421 ;;    (list (numerator rat) (denominator rat))))
  422 ;;(define (find-ratio-between x y)
  423 ;;  (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
  424 
  425 ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
  426 ;;; be returned by CHAR->INTEGER.
  427 (define char-code-limit (+ 1 #x10ffff))
  428 
  429 ;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
  430 (define (slib:eval expression)
  431   (eval expression (interaction-environment)))
  432 
  433 ;;; Define SLIB:EXIT to be the implementation procedure to exit or
  434 ;;; return if exiting not supported.
  435 (define slib:exit quit)
  436 
  437 ;@
  438 (define scheme-file-suffix
  439    (lambda () ".scm"))
  440  
  441 (define (slib:load <pathname>)
  442   (load (string-append <pathname> (scheme-file-suffix))))
  443 
  444 ;;;(SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
  445 ;;;suffix all the module files in SLIB have.  See feature 'SOURCE.
  446 (define slib:load-source slib:load)
  447 
  448 ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
  449 ;;; by compiling "foo.scm" if this implementation can compile files.
  450 ;;; See feature 'COMPILED.
  451 (define slib:load-compiled slib:load)
  452 
  453 (define defmacro:eval slib:eval)
  454 (define defmacro:load slib:load)
  455 
  456 (define (defmacro:expand* x)
  457   (require 'defmacroexpand)
  458   (defmacro:expand* x))
  459 
  460 ;@
  461 (define gentemp
  462   (let ((*gensym-counter* -1))
  463     (lambda ()
  464       (set! *gensym-counter* (+ *gensym-counter* 1))
  465       (string->symbol
  466        (string-append "slib:G" (number->string *gensym-counter*))))))
  467 
  468 ;;; If your implementation provides R4RS macros:
  469 (define macro:eval slib:eval)
  470 (define macro:load slib:load-source)
  471 
  472 (define slib:warn warn)
  473 (define slib:error error)
  474 
  475 ;;; define these as appropriate for your system.
  476 (define slib:tab #\tab)
  477 (define slib:form-feed #\page)
  478 
  479 ;;; {Time}
  480 (define difftime -)
  481 (define offset-time +)
  482 
  483 ;;; Early version of 'logical is built-in
  484 (define (copy-bit index to bool)
  485   (if bool
  486       (logior to (arithmetic-shift 1 index))
  487       (logand to (lognot (arithmetic-shift 1 index)))))
  488 (define (bit-field n start end)
  489   (logand (- (expt 2 (- end start)) 1)
  490 	  (arithmetic-shift n (- start))))
  491 (define (bitwise-if mask n0 n1)
  492   (logior (logand mask n0)
  493 	  (logand (lognot mask) n1)))
  494 (define (copy-bit-field to from start end)
  495   (bitwise-if (arithmetic-shift (lognot (ash -1 (- end start))) start)
  496 	      (arithmetic-shift from start)
  497 	      to))
  498 (define (rotate-bit-field n count start end)
  499   (define width (- end start))
  500   (set! count (modulo count width))
  501   (let ((mask (lognot (ash -1 width))))
  502     (define azn (logand mask (arithmetic-shift n (- start))))
  503     (logior (arithmetic-shift
  504 	     (logior (logand mask (arithmetic-shift azn count))
  505 		     (arithmetic-shift azn (- count width)))
  506 	     start)
  507 	    (logand (lognot (ash mask start)) n))))
  508 (define (log2-binary-factors n)
  509   (+ -1 (integer-length (logand n (- n)))))
  510 (define (bit-reverse k n)
  511   (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1))
  512        (k (+ -1 k) (+ -1 k))
  513        (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m))))
  514       ((negative? k) (if (negative? n) (lognot rvs) rvs))))
  515 (define (reverse-bit-field n start end)
  516   (define width (- end start))
  517   (let ((mask (lognot (ash -1 width))))
  518     (define zn (logand mask (arithmetic-shift n (- start))))
  519     (logior (arithmetic-shift (bit-reverse width zn) start)
  520 	    (logand (lognot (ash mask start)) n))))
  521 
  522 (define* (integer->list k len)
  523   (if len
  524       (do ((idx (+ -1 len) (+ -1 idx))
  525 	   (k k (arithmetic-shift k -1))
  526 	   (lst '() (cons (odd? k) lst)))
  527 	  ((negative? idx) lst))
  528       (do ((k k (arithmetic-shift k -1))
  529 	   (lst '() (cons (odd? k) lst)))
  530 	  ((<= k 0) lst))))
  531 (define (list->integer bools)
  532   (do ((bs bools (cdr bs))
  533        (acc 0 (+ acc acc (if (car bs) 1 0))))
  534       ((null? bs) acc)))
  535 (define (booleans->integer . bools)
  536   (list->integer bools))
  537 
  538 ;;;; SRFI-60 aliases
  539 (define arithmetic-shift ash)
  540 (define bitwise-ior logior)
  541 (define bitwise-xor logxor)
  542 (define bitwise-and logand)
  543 (define bitwise-not lognot)
  544 ;;(define bit-count logcount)
  545 (define bit-set?   logbit?)
  546 (define any-bits-set? logtest)
  547 (define first-set-bit log2-binary-factors)
  548 (define bitwise-merge bitwise-if)
  549 
  550 ;;; array-for-each
  551 (define (array-indexes ra)
  552   (let ((ra0 (apply make-array '#() (array-shape ra))))
  553     (array-index-map! ra0 list)
  554     ra0))
  555 (define (array:copy! dest source)
  556   (array-map! dest identity source))
  557 
  558 (define make-array
  559   (lambda (prot . args)
  560     (let ((fill (if (memv 0 (array-dimensions prot))
  561                    *unspecified*
  562                    (apply array-ref prot (map car (array-shape prot))))))
  563       (apply make-typed-array
  564             (array-type prot)
  565             fill
  566             args))))
  567 
  568 (define (list->array rank proto lst)
  569   (define dimensions
  570     (do ((shp '() (cons (length row) shp))
  571 	 (row lst (car lst))
  572 	 (rnk (+ -1 rank) (+ -1 rnk)))
  573 	((negative? rnk) (reverse shp))))
  574   (let ((nra (apply make-array proto dimensions)))
  575     (define (l2ra dims idxs row)
  576       (cond ((null? dims)
  577 	     (apply array-set! nra row (reverse idxs)))
  578 	    ((if (not (eqv? (car dims) (length row)))
  579 		 (slib:error 'list->array
  580 			     'non-rectangular 'array dims dimensions))
  581 	     (do ((idx 0 (+ 1 idx))
  582 		  (row row (cdr row)))
  583 		 ((>= idx (car dims)))
  584 	       (l2ra (cdr dims) (cons idx idxs) (car row))))))
  585     (l2ra dimensions '() lst)
  586     nra))
  587 
  588 (define (vector->array vect prototype . dimensions)
  589   (define vdx (vector-length vect))
  590   (if (not (eqv? vdx (apply * dimensions)))
  591       (slib:error 'vector->array vdx '<> (cons '* dimensions)))
  592   (let ((ra (apply make-array prototype dimensions)))
  593     (define (v2ra dims idxs)
  594       (cond ((null? dims)
  595 	     (set! vdx (+ -1 vdx))
  596 	     (apply array-set! ra (vector-ref vect vdx) (reverse idxs)))
  597 	    (else
  598 	     (do ((idx (+ -1 (car dims)) (+ -1 idx)))
  599 		 ((negative? idx) vect)
  600 	       (v2ra (cdr dims) (cons idx idxs))))))
  601     (v2ra dimensions '())
  602     ra))
  603 (define (array->vector ra)
  604   (define dims (array-dimensions ra))
  605   (let* ((vdx (apply * dims))
  606 	 (vect (make-vector vdx)))
  607     (define (ra2v dims idxs)
  608       (if (null? dims)
  609 	  (let ((val (apply array-ref ra (reverse idxs))))
  610 	    (set! vdx (+ -1 vdx))
  611 	    (vector-set! vect vdx val))
  612 	  (do ((idx (+ -1 (car dims)) (+ -1 idx)))
  613 	      ((negative? idx) vect)
  614 	    (ra2v (cdr dims) (cons idx idxs)))))
  615     (ra2v dims '())
  616     vect))
  617 
  618 (define create-array make-array)
  619 (define (make-typed-wrapper pair)
  620   (lambda opt
  621     (if (null? opt)
  622        (list->typed-array (car pair) 1 (list (cdr pair)))
  623        (list->typed-array (car pair) 0 (car opt)))))
  624 (define ac64 (make-typed-wrapper '(c64 . 0.0+0.0i)))
  625 (define ac32 (make-typed-wrapper '(c32 . 0.0+0.0i)))
  626 (define ar64 (make-typed-wrapper '(f64 . 0.0)))
  627 (define ar32 (make-typed-wrapper '(f32 . 0.0)))
  628 (define as64 (make-typed-wrapper '(s64 . 0)))
  629 (define as32 (make-typed-wrapper '(s32 . 0)))
  630 (define as16 (make-typed-wrapper '(s16 . 0)))
  631 (define as8  (make-typed-wrapper '(s8 . 0)))
  632 (define au64 (make-typed-wrapper '(u64 . 0)))
  633 (define au32 (make-typed-wrapper '(u32 . 0)))
  634 (define au16 (make-typed-wrapper '(u16 . 0)))
  635 (define au8  (make-typed-wrapper '(u8 . 0)))
  636 (define at1  (make-typed-wrapper '(b . #f)))
  637 
  638 ;;; New SRFI-58 names
  639 ;; flonums
  640 (define A:floC128b ac64)
  641 (define A:floC64b ac64)
  642 (define A:floC32b ac32)
  643 (define A:floC16b ac32)
  644 (define A:floR128b ar64)
  645 (define A:floR64b ar64)
  646 (define A:floR32b ar32)
  647 (define A:floR16b ar32)
  648 ;; decimal flonums
  649 (define A:floR128d ar64)
  650 (define A:floR64d ar64)
  651 (define A:floR32d ar32)
  652 ;; fixnums
  653 (define A:fixZ64b as64)
  654 (define A:fixZ32b as32)
  655 (define A:fixZ16b as16)
  656 (define A:fixZ8b  as8)
  657 (define A:fixN64b au64)
  658 (define A:fixN32b au32)
  659 (define A:fixN16b au16)
  660 (define A:fixN8b  au8)
  661 (define A:bool    at1)
  662 
  663 ;;; And case-insensitive versions
  664 ;; flonums
  665 (define a:floc128b ac64)
  666 (define a:floc64b ac64)
  667 (define a:floc32b ac32)
  668 (define a:floc16b ac32)
  669 (define a:flor128b ar64)
  670 (define a:flor64b ar64)
  671 (define a:flor32b ar32)
  672 (define a:flor16b ar32)
  673 ;; decimal flonums
  674 (define a:flor128d ar64)
  675 (define a:flor64d ar64)
  676 (define a:flor32d ar32)
  677 ;; fixnums
  678 (define a:fixz64b as64)
  679 (define a:fixz32b as32)
  680 (define a:fixz16b as16)
  681 (define a:fixz8b  as8)
  682 (define a:fixn64b au64)
  683 (define a:fixn32b au32)
  684 (define a:fixn16b au16)
  685 (define a:fixn8b  au8)
  686 (define a:bool    at1)
  687 
  688 ;;; {Random numbers}
  689 (define (make-random-state . args)
  690   (let ((seed (if (null? args) *random-state* (car args))))
  691     (cond ((string? seed))
  692 	  ((number? seed) (set! seed (number->string seed)))
  693 	  (else (let ()
  694 		  (require 'object->string)
  695 		  (set! seed (object->limited-string seed 50)))))
  696     (seed->random-state seed)))
  697 (define (random:chunk sta) (random 256 sta))
  698 
  699 (define t #t)
  700 (define nil #f)
  701 
  702 ;;; rev2-procedures
  703 (define <? <)
  704 (define <=? <=)
  705 (define =? =)
  706 (define >? >)
  707 (define >=? >=)
  708 
  709 (slib:load (in-vicinity (library-vicinity) "require"))