121 lines
2.8 KiB
Scheme
121 lines
2.8 KiB
Scheme
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
||
|
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
|
||
|
|
; This is file pseudoscheme-features.scm.
|
||
|
|
; Synchronize any changes with all the other *-features.scm files.
|
||
|
|
|
||
|
|
(define *load-file-type* #f) ;For fun
|
||
|
|
|
||
|
|
|
||
|
|
; SIGNALS
|
||
|
|
|
||
|
|
(define error #'ps:scheme-error)
|
||
|
|
|
||
|
|
(define warn #'ps:scheme-warn)
|
||
|
|
|
||
|
|
(define (signal type . stuff)
|
||
|
|
(apply warn "condition signalled" type stuff))
|
||
|
|
|
||
|
|
(define (syntax-error . rest) ; Must return a valid expression.
|
||
|
|
(apply warn rest)
|
||
|
|
''syntax-error)
|
||
|
|
|
||
|
|
(define (call-error message proc . args)
|
||
|
|
(error message (cons proc args)))
|
||
|
|
|
||
|
|
|
||
|
|
; HANDLE
|
||
|
|
|
||
|
|
(define (ignore-errors thunk)
|
||
|
|
#-Lucid
|
||
|
|
'(error "ignore-errors isn't implemented") ;No big deal if it doesn't work.
|
||
|
|
#+Lucid
|
||
|
|
(let ((result (lcl:ignore-errors (thunk))))
|
||
|
|
(lisp:if (lisp:typep result 'lcl:condition)
|
||
|
|
(list 'error result)
|
||
|
|
result)))
|
||
|
|
|
||
|
|
|
||
|
|
; FEATURES
|
||
|
|
|
||
|
|
(define force-output #'lisp:force-output)
|
||
|
|
|
||
|
|
(define (string-hash s)
|
||
|
|
(let ((n (string-length s)))
|
||
|
|
(do ((i 0 (+ i 1))
|
||
|
|
(h 0 (+ h (lisp:char-code (string-ref s i)))))
|
||
|
|
((>= i n) h))))
|
||
|
|
|
||
|
|
(define (make-immutable! thing) #f)
|
||
|
|
(define (immutable? thing) #f)
|
||
|
|
(define (unspecific) (if #f #f))
|
||
|
|
|
||
|
|
|
||
|
|
; BITWISE
|
||
|
|
|
||
|
|
(define arithmetic-shift #'lisp:ash)
|
||
|
|
(define bitwise-and #'lisp:logand)
|
||
|
|
(define bitwise-ior #'lisp:logior)
|
||
|
|
|
||
|
|
|
||
|
|
; ASCII
|
||
|
|
|
||
|
|
(define char->ascii #'lisp:char-code)
|
||
|
|
(define ascii->char #'lisp:code-char)
|
||
|
|
|
||
|
|
|
||
|
|
; CODE-VECTORS
|
||
|
|
|
||
|
|
(define (make-code-vector len . fill-option)
|
||
|
|
(lisp:make-array len :element-type '(lisp:unsigned-byte 8)
|
||
|
|
:initial-element (if (null? fill-option)
|
||
|
|
0
|
||
|
|
(car fill-option))))
|
||
|
|
|
||
|
|
(define (code-vector? obj)
|
||
|
|
(ps:true? (lisp:typep obj
|
||
|
|
(lisp:quote (lisp:simple-array (lisp:unsigned-byte 8)
|
||
|
|
(lisp:*))))))
|
||
|
|
|
||
|
|
(define (code-vector-ref bv k)
|
||
|
|
(lisp:aref (lisp:the (lisp:simple-array (lisp:unsigned-byte 8) (lisp:*))
|
||
|
|
bv)
|
||
|
|
k))
|
||
|
|
|
||
|
|
(define (code-vector-set! bv k val)
|
||
|
|
(lisp:setf (lisp:aref (lisp:the (lisp:simple-array (lisp:unsigned-byte 8)
|
||
|
|
(lisp:*))
|
||
|
|
bv)
|
||
|
|
k)
|
||
|
|
val))
|
||
|
|
|
||
|
|
(define (code-vector-length bv)
|
||
|
|
(lisp:length (lisp:the (lisp:simple-array (lisp:unsigned-byte 8) (lisp:*))
|
||
|
|
bv)))
|
||
|
|
|
||
|
|
|
||
|
|
; The rest is unnecessary in Pseudoscheme versions 2.8d and after.
|
||
|
|
|
||
|
|
;(define eval #'schi:scheme-eval)
|
||
|
|
;(define (interaction-environment) schi:*current-rep-environment*)
|
||
|
|
;(define scheme-report-environment
|
||
|
|
; (let ((env (scheme-translator:make-program-env
|
||
|
|
; 'rscheme
|
||
|
|
; (list scheme-translator:revised^4-scheme-module))))
|
||
|
|
; (lambda (n)
|
||
|
|
; n ;ignore
|
||
|
|
; env)))
|
||
|
|
|
||
|
|
; Dynamic-wind.
|
||
|
|
;
|
||
|
|
;(define (dynamic-wind in body out)
|
||
|
|
; (in)
|
||
|
|
; (lisp:unwind-protect (body)
|
||
|
|
; (out)))
|
||
|
|
;
|
||
|
|
;(define values #'lisp:values)
|
||
|
|
;
|
||
|
|
;(define (call-with-values thunk receiver)
|
||
|
|
; (lisp:multiple-value-call receiver (thunk)))
|