180 lines
4.6 KiB
Scheme
180 lines
4.6 KiB
Scheme
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
|
|
;;;
|
|
;;; Port Author: Andrew Whatson
|
|
;;;
|
|
;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Robert Ransom
|
|
;;;
|
|
;;; scheme48-1.9.2/scheme/big/big-util.scm
|
|
;;; scheme48-1.9.2/scheme/rts/exception.scm
|
|
|
|
(define-module (prescheme scheme48)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (ice-9 textual-ports)
|
|
#:use-module (srfi srfi-8)
|
|
#:use-module (srfi srfi-60)
|
|
#:use-module (rnrs bytevectors)
|
|
#:use-module (rnrs io ports)
|
|
#:use-module (prescheme s48-defenum)
|
|
#:export (arithmetic-shift
|
|
ascii->char
|
|
char->ascii
|
|
unspecific
|
|
make-code-vector
|
|
code-vector-ref
|
|
code-vector-set!
|
|
code-vector-length
|
|
make-table
|
|
make-symbol-table
|
|
table-ref
|
|
table-set!
|
|
table-walk
|
|
byte-ready?
|
|
peek-byte
|
|
read-byte
|
|
write-byte
|
|
current-column
|
|
current-line
|
|
make-tracking-input-port
|
|
make-tracking-output-port
|
|
assertion-violation
|
|
concatenate-symbol
|
|
breakpoint
|
|
atom?
|
|
neq?
|
|
n=
|
|
memq?
|
|
first
|
|
any
|
|
no-op
|
|
null-list?
|
|
any?
|
|
every?
|
|
filter-map
|
|
partition-list)
|
|
#:re-export (define-enumeration
|
|
enum
|
|
name->enumerand
|
|
enumerand->name
|
|
bitwise-and
|
|
bitwise-ior
|
|
bitwise-xor
|
|
bitwise-not
|
|
receive))
|
|
|
|
(define arithmetic-shift ash)
|
|
|
|
(define ascii->char integer->char)
|
|
(define char->ascii char->integer)
|
|
|
|
(define unspecific (if #f #f))
|
|
|
|
(define make-code-vector make-bytevector)
|
|
(define code-vector-ref bytevector-u8-ref)
|
|
(define code-vector-set! bytevector-u8-set!)
|
|
(define code-vector-length bytevector-length)
|
|
|
|
(define make-table make-hash-table)
|
|
(define make-symbol-table make-hash-table)
|
|
(define table-ref hash-ref)
|
|
(define table-set! hash-set!)
|
|
(define table-walk hash-for-each)
|
|
|
|
(define byte-ready? char-ready?)
|
|
(define peek-byte lookahead-u8)
|
|
(define read-byte get-u8)
|
|
(define write-byte put-u8)
|
|
|
|
(define current-column port-column)
|
|
(define current-line port-line)
|
|
(define make-tracking-input-port identity)
|
|
(define make-tracking-output-port identity)
|
|
|
|
(define (assertion-violation who message . irritants)
|
|
(apply error message irritants))
|
|
|
|
(define (concatenate-symbol . stuff)
|
|
(string->symbol
|
|
(apply string-append
|
|
(map (lambda (x)
|
|
(cond ((string? x) x)
|
|
((symbol? x) (symbol->string x))
|
|
((number? x) (number->string x))
|
|
(else
|
|
(assertion-violation 'concatenate-symbol "cannot coerce to a string"
|
|
x))))
|
|
stuff))))
|
|
|
|
(define (breakpoint format-string . args)
|
|
(error (apply format (cons #f (cons format-string args)))))
|
|
|
|
(define (atom? x)
|
|
(not (pair? x)))
|
|
|
|
(define (neq? a b)
|
|
(not (eq? a b)))
|
|
|
|
(define (n= x y)
|
|
(not (= x y)))
|
|
|
|
(define (memq? x l)
|
|
(let loop ((l l))
|
|
(cond ((null? l) #f)
|
|
((eq? x (car l)) #t)
|
|
(else (loop (cdr l))))))
|
|
|
|
(define (first pred list)
|
|
(let loop ((list list))
|
|
(cond ((null? list)
|
|
#f)
|
|
((pred (car list))
|
|
(car list))
|
|
(else
|
|
(loop (cdr list))))))
|
|
|
|
(define any first) ;; ANY need not search in order, but it does anyway
|
|
|
|
(define (no-op x) x)
|
|
|
|
(define (null-list? x)
|
|
(cond ((null? x) #t)
|
|
((pair? x) #f)
|
|
(else
|
|
(assertion-violation 'null-list? "non-list" x))))
|
|
|
|
(define (any? proc list)
|
|
(let loop ((list list))
|
|
(cond ((null? list)
|
|
#f)
|
|
((proc (car list))
|
|
#t)
|
|
(else
|
|
(loop (cdr list))))))
|
|
|
|
(define (every? pred list)
|
|
(let loop ((list list))
|
|
(cond ((null? list)
|
|
#t)
|
|
((pred (car list))
|
|
(loop (cdr list)))
|
|
(else
|
|
#f))))
|
|
|
|
(define (filter-map f l)
|
|
(let loop ((l l) (r '()))
|
|
(cond ((null? l)
|
|
(reverse r))
|
|
((f (car l))
|
|
=> (lambda (x)
|
|
(loop (cdr l) (cons x r))))
|
|
(else
|
|
(loop (cdr l) r)))))
|
|
|
|
(define (partition-list pred l)
|
|
(let loop ((l l) (yes '()) (no '()))
|
|
(cond ((null? l)
|
|
(values (reverse yes) (reverse no)))
|
|
((pred (car l))
|
|
(loop (cdr l) (cons (car l) yes) no))
|
|
(else
|
|
(loop (cdr l) yes (cons (car l) no))))))
|