;;; 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 (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
            table-ref
            table-set!
            table-walk
            byte-ready?
            peek-byte
            read-byte
            write-byte
            assertion-violation
            concatenate-symbol
            atom?
            neq?
            n=
            memq?
            null-list?
            every?
            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 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 (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 (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 (null-list? x)
  (cond ((null? x) #t)
        ((pair? x) #f)
        (else
         (assertion-violation 'null-list? "non-list" x))))

(define (every? pred list)
  (let loop ((list list))
    (cond ((null? list)
           #t)
          ((pred (car list))
           (loop (cdr list)))
          (else
           #f))))

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