117 lines
2.6 KiB
Scheme
117 lines
2.6 KiB
Scheme
; This is a init file for Mini-Scheme.
|
|
; Modified for UNSLISP.
|
|
|
|
(define modulo remainder)
|
|
|
|
(define (caar x) (car (car x)))
|
|
(define (cadr x) (car (cdr x)))
|
|
(define (cdar x) (cdr (car x)))
|
|
(define (cddr x) (cdr (cdr x)))
|
|
(define (caaar x) (car (car (car x))))
|
|
(define (caadr x) (car (car (cdr x))))
|
|
(define (cadar x) (car (cdr (car x))))
|
|
(define (caddr x) (car (cdr (cdr x))))
|
|
(define (cdaar x) (cdr (car (car x))))
|
|
(define (cdadr x) (cdr (car (cdr x))))
|
|
(define (cddar x) (cdr (cdr (car x))))
|
|
(define (cdddr x) (cdr (cdr (cdr x))))
|
|
|
|
(define (list . x) x)
|
|
|
|
(define (map proc list)
|
|
(if (pair? list)
|
|
(cons (proc (car list)) (map proc (cdr list)))))
|
|
|
|
(define (for-each proc list)
|
|
(if (pair? list)
|
|
(begin (proc (car list)) (for-each proc (cdr list)))
|
|
#t ))
|
|
|
|
(define (list-tail x k)
|
|
(if (zero? k)
|
|
x
|
|
(list-tail (cdr x) (- k 1))))
|
|
|
|
(define (list-ref x k)
|
|
(car (list-tail x k)))
|
|
|
|
(define list-set!
|
|
(lambda (lst k obj)
|
|
(if (= k 0)
|
|
(set-car! lst obj)
|
|
(list-set! (cdr lst) (- k 1) obj))))
|
|
|
|
(define (last-pair x)
|
|
(if (pair? (cdr x))
|
|
(last-pair (cdr x))
|
|
x))
|
|
|
|
(define vector list)
|
|
(define vector-ref list-ref)
|
|
(define vector-set! list-set!)
|
|
|
|
(define make-vector
|
|
(lambda (num)
|
|
(letrec
|
|
((loop
|
|
(lambda (iter cell)
|
|
(if (= iter 0)
|
|
cell
|
|
(loop (- iter 1) (cons #f cell))))))
|
|
(loop num '()))))
|
|
|
|
(define (head stream) (car stream))
|
|
|
|
(define (tail stream) (force (cdr stream)))
|
|
|
|
(define (eof-object? x) (eq? x #f))
|
|
|
|
;;;;; following part is written by a.k
|
|
|
|
;;;; atom?
|
|
(define (atom? x)
|
|
(not (pair? x)))
|
|
|
|
;;;; memq
|
|
(define (memq obj lst)
|
|
(cond
|
|
((null? lst) #f)
|
|
((eq? obj (car lst)) lst)
|
|
(else (memq obj (cdr lst)))))
|
|
|
|
;;;; equal?
|
|
(define (equal? x y)
|
|
(if (pair? x)
|
|
(and (pair? y)
|
|
(equal? (car x) (car y))
|
|
(equal? (cdr x) (cdr y)))
|
|
(and (not (pair? y))
|
|
(eqv? x y))))
|
|
|
|
;;; Emulation of mutable strings.
|
|
|
|
(define string-ref list-ref)
|
|
(define string-set! list-set!)
|
|
(define string list)
|
|
|
|
(define list<=>
|
|
(lambda (x y <=>)
|
|
(cond
|
|
((and (null? x) (null? y)) '=)
|
|
((null? x) '<)
|
|
((null? y) '>)
|
|
(else
|
|
(let ((dir (<=> (car x) (car y))))
|
|
(if (eq? dir '=)
|
|
(list<=> (cdr x) (cdr y) <=>)
|
|
dir))))))
|
|
|
|
(define string<=>
|
|
(lambda (x y)
|
|
(list<=> x y (lambda (x y)
|
|
(if (eqv? x y)
|
|
'=
|
|
(if (< (char->integer x) (char->integer y))
|
|
'<
|
|
'>))))))
|