scsh-0.5/alt/pseudoscheme-features.scm

121 lines
2.8 KiB
Scheme
Raw Normal View History

1995-10-13 23:34:21 -04:00
; -*- 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)))