82 lines
2.0 KiB
Scheme
82 lines
2.0 KiB
Scheme
;; Library functions for Vx-Scheme
|
|
;;
|
|
;; Copyright (c) 2003,2006 and onwards Colin Smith
|
|
;;
|
|
;; These are procedures designed to run in the virtual machine. They
|
|
;; cannot be implemented in C, because each of these arguments takes a
|
|
;; parameter of procedure type. The C implementation would then be
|
|
;; forced to reenter the virtual machine, which is not allowed. By
|
|
;; implementing these procedures in Scheme itself, we can produce
|
|
;; bytecode that the VM can execute.
|
|
;;
|
|
;;
|
|
|
|
; =================
|
|
; LIBRARY FUNCTIONS
|
|
; =================
|
|
|
|
(define (map fn . arglists)
|
|
(define (map0 fn arglists)
|
|
(let loop ((results '())
|
|
(rest arglists))
|
|
(if (null? (car rest))
|
|
results
|
|
(loop (append
|
|
results
|
|
(list
|
|
(apply fn
|
|
(let car-loop ((rest1 rest)
|
|
(args '()))
|
|
(if (null? rest1)
|
|
args
|
|
(car-loop (cdr rest1)
|
|
(append args (list (caar rest1)))))))))
|
|
(let cdr-loop ((rest1 rest)
|
|
(args '()))
|
|
|
|
(if (null? rest1)
|
|
args
|
|
(cdr-loop (cdr rest1)
|
|
(append args (list (cdar rest1))))))))))
|
|
(map0 fn arglists))
|
|
|
|
(define (for-each fn . arglists)
|
|
(define (for-each0 fn arglists)
|
|
(let loop ((rest arglists))
|
|
(if (null? (car rest))
|
|
(if #f #f) ; unspecified
|
|
(begin
|
|
(apply fn
|
|
(let car-loop ((rest1 rest)
|
|
(args '()))
|
|
(if (null? rest1)
|
|
args
|
|
(car-loop (cdr rest1)
|
|
(append args (list (caar rest1)))))))
|
|
(loop (let cdr-loop ((rest1 rest)
|
|
(args '()))
|
|
(if (null? rest1)
|
|
args
|
|
(cdr-loop (cdr rest1)
|
|
(append args (list (cdar rest1)))))))))))
|
|
(for-each0 fn arglists))
|
|
|
|
(define (call-with-input-file filename procedure)
|
|
(let ((open-file (open-input-file filename)))
|
|
(procedure open-file)))
|
|
|
|
(define (call-with-output-file filename procedure)
|
|
(let* ((open-file (open-output-file filename))
|
|
(value (procedure open-file)))
|
|
(close-output-port open-file)
|
|
value))
|
|
|
|
(define (load file)
|
|
(let ((input (open-input-file file)))
|
|
(do ((form (read input) (read input)))
|
|
((eof-object? form) 'ok)
|
|
(eval form))))
|
|
|
|
|
|
|