guile-prescheme/prescheme/scheme48.scm

;;; 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))))))