Arthur Barraux
91 lines
3.1 KiB
Scheme
91 lines
3.1 KiB
Scheme
(define-macro lambda (/\_ args
|
|
(if (pair? args)
|
|
(if (pair? (cdr args))
|
|
(if (pair? (cdr (cdr args)))
|
|
`(/\_ ,(car args) ,(cons 'BEGIN (cdr args)))
|
|
`(/\_ ,(car args) ,(car (cdr args))))
|
|
(syntax-error "lambda missing body expressions: (lambda (args) body)"))
|
|
(syntax-error "lambda missing argument: (lambda (args) body)"))))
|
|
|
|
(define-macro set! (lambda (var x)
|
|
(begin
|
|
(if (not (symbol? var)) (syntax-error "set! not a variable"))
|
|
`(_SET! ,var ,x))))
|
|
|
|
(define-macro define
|
|
(lambda (var . exprs)
|
|
(if (symbol? var)
|
|
(if (pair? (cdr exprs))
|
|
(syntax-error "define: (define var x)")
|
|
`(_DEF ,var ,(car exprs)))
|
|
(if (pair? var)
|
|
`(_DEF ,(car var)
|
|
(LAMBDA ,(cdr var)
|
|
,(if (null? (cdr exprs)) (car exprs) (cons 'BEGIN exprs))))
|
|
(syntax-error "define: not a symbol") ))))
|
|
|
|
(define (first x) (car x))
|
|
(define (second x) (car (cdr x)))
|
|
(define (third x) (car (cdr (cdr x))))
|
|
|
|
(define (some? pred l)
|
|
(if (null? l) #f
|
|
(if (pred (car l)) #t
|
|
(some? pred (cdr l)))))
|
|
|
|
(define (_map1-helper proc l result)
|
|
(if (null? l)
|
|
(reverse! result)
|
|
(_map1-helper proc
|
|
(cdr l)
|
|
(cons (proc (car l)) result))))
|
|
|
|
(define (map1 proc l) (_map1-helper proc l '()))
|
|
|
|
(define (for-each1 proc l)
|
|
(if (null? l) '()
|
|
(begin (proc (car l)) (for-each1 proc (cdr l )))))
|
|
|
|
(define (reverse! l) (append-reverse! l '()))
|
|
(define (reverse l) (reverse! (list-copy l)))
|
|
|
|
(define (last-pair x)
|
|
(if (pair? (cdr x))
|
|
(last-pair (cdr x)) x))
|
|
|
|
(define (list-tail x k)
|
|
(if (zero? k) x
|
|
(list-tail (cdr x) (- k 1))))
|
|
|
|
(define (fold-left op acc lst)
|
|
(if (null? lst) acc
|
|
(fold-left op (op acc (car lst)) (cdr lst))))
|
|
|
|
(define (_expand-shorthand-body path)
|
|
(if (null? path) (cons 'pair '())
|
|
(list (if (char=? (car path) #\A)
|
|
(cons 'CAR (_expand-shorthand-body (cdr path)))))))
|
|
|
|
(define (_expand-shorthand text)
|
|
(cons 'DEFINE (cons (list (string->symbol (string-append "C" text "R")) 'pair)
|
|
(_expand-shorthand-body (string->list text)))))
|
|
|
|
(define-macro _shorthand-accessors (lambda args (cons 'BEGIN (map1 _expand-shorthand args))))
|
|
|
|
(define (vector . args) (list->vector args))
|
|
|
|
(define (vector-copy v) (subvector v 0 (vector-length v)))
|
|
(define (vector-head v end) (subvector v 0 end))
|
|
(define (vector-tail v start) (subvector v start (vector-length v)))
|
|
|
|
(define (string . chars) (list->string chars))
|
|
|
|
(define (string>=? a b) (not (string<? a b)))
|
|
(define (string>? a b) (string<? b a))
|
|
(define (string<=? a b) (not (string<? b a)))
|
|
|
|
(define (string-copy s) (substring s 0 (string-length v)))
|
|
(define (string-head s end) (subvector s 0 end))
|
|
(define (string-tail s start) (subvector s start (string-length v)))
|
|
|