177 lines
4.2 KiB
Scheme
177 lines
4.2 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))
|
|
'<
|
|
'>))))))
|
|
|
|
(define max
|
|
(lambda (curmax . rest)
|
|
(if (null? rest)
|
|
curmax
|
|
(let ((next-num (car rest)))
|
|
(apply max
|
|
(cons (if (> next-num curmax) next-num curmax)
|
|
(cdr rest)))))))
|
|
|
|
(define all
|
|
(lambda (f l)
|
|
(cond
|
|
((null? l) #t)
|
|
((not (f (car l))) (all f (cdr l)))
|
|
(else #f))))
|
|
|
|
(define any
|
|
(lambda (f l)
|
|
(cond
|
|
((null? l) #f)
|
|
((f (car l)) #t)
|
|
(else (any f (cdr l))))))
|
|
|
|
(macro
|
|
cond-expand
|
|
(lambda (body)
|
|
(letrec
|
|
((loop
|
|
(lambda (body)
|
|
(if (null? body)
|
|
#f
|
|
(let ((elem (car body)))
|
|
(cond
|
|
((eqv? (car elem) 'else)
|
|
(cons 'begin (cdr elem)))
|
|
((and (pair? elem)
|
|
(passes? (car elem)))
|
|
(cons 'begin (cdr elem)))
|
|
(else (loop (cdr body))))))))
|
|
(passes?
|
|
(lambda (boolean-form)
|
|
(cond
|
|
((eqv? boolean-form 'miniscm-unslisp) #t)
|
|
((eqv? boolean-form 'r3rs) #t)
|
|
((symbol? boolean-form) #f)
|
|
((not (pair? boolean-form)) (error "invalid boolean form"))
|
|
((eqv? (car boolean-form) 'and)
|
|
(all passes? (cdr boolean-form)))
|
|
((eqv? (car boolean-form) 'or)
|
|
(any passes? (cdr boolean-form)))
|
|
((eqv? (car boolean-form) 'not)
|
|
(not (passes? (cadr boolean-form))))
|
|
(else (error "invalid boolean function"))))))
|
|
(loop (cdr body)))))
|
|
|
|
(define (abs x)
|
|
(if (< x 0)
|
|
(- x)
|
|
x))
|