diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 6dd83d85..6f61ea3d 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -32,6 +32,174 @@ (walk (lambda (x) (if (symbol? x) (inject x) x)) expr)) (make-syntactic-closure mac-env '() (f renamed inject compare)))) +;;; Core syntaxes + +(define (list . args) + args) + +(define (caar p) + (car (car p))) + +(define (cadr p) + (car (cdr p))) + +(define (cdar p) + (cdr (car p))) + +(define (cddr p) + (cdr (cdr p))) + +(define (any pred list) + (if (null? list) + #f + ((lambda (it) + (if it + it + (any pred (cdr list)))) + (pred (car list))))) + +(define (map f list . lists) + (define (single-map f list) + (if (null? list) + '() + (cons (f (car list)) + (map f (cdr list))))) + (define (multiple-map f lists) + (if (any null? lists) + '() + (cons (apply f (single-map car lists)) + (multiple-map f (single-map cdr lists))))) + (if (null? lists) + (single-map f list) + (multiple-map f (cons list lists)))) + +(define-macro (let bindings . body) + (if (symbol? bindings) + (begin + (define name bindings) + (set! bindings (car body)) + (set! body (cdr body)) + ;; expanded form should be like below: + ;; `(let () + ;; (define ,loop + ;; (lambda (,@vars) + ;; ,@body)) + ;; (,loop ,@vals)) + (list 'let '() + (list 'define name + (cons 'lambda (cons (map car bindings) body))) + (cons name (map cadr bindings)))) + (cons (cons 'lambda (cons (map car bindings) body)) + (map cadr bindings)))) + +(define-macro (cond . clauses) + (if (null? clauses) + #f + (let ((c (car clauses))) + (let ((test (car c)) + (if-true (cons 'begin (cdr c))) + (if-false (cons 'cond (cdr clauses)))) + (list 'if test if-true if-false))))) + +(define-macro (and . exprs) + (if (null? exprs) + #t + (let ((test (car exprs)) + (if-true (cons 'and (cdr exprs)))) + (list 'if test if-true #f)))) + +(define-macro (or . exprs) + (if (null? exprs) + #f + (let ((test (car exprs)) + (if-false (cons 'or (cdr exprs)))) + (list 'let (list (list 'it test)) + (list 'if 'it 'it if-false))))) + +(define (append xs ys) + (if (null? xs) + ys + (cons (car xs) + (append (cdr xs) ys)))) + +(define-macro (quasiquote x) + (cond + ((symbol? x) (list 'quote x)) + ((pair? x) + (cond + ((eq? 'unquote (car x)) (cadr x)) + ((and (pair? (car x)) + (eq? 'unquote-splicing (caar x))) + (list 'append (cadr (car x)) (list 'quasiquote (cdr x)))) + (#t (list 'cons + (list 'quasiquote (car x)) + (list 'quasiquote (cdr x)))))) + (#t x))) + +(define-macro (let* bindings . body) + (if (null? bindings) + `(let () ,@body) + `(let ((,(caar bindings) + ,@(cdar bindings))) + (let* (,@(cdr bindings)) + ,@body)))) + +(define-macro (letrec bindings . body) + (let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) + (initials (map (lambda (v) `(set! ,@v)) bindings))) + `(let (,@vars) + (begin ,@initials) + ,@body))) + +(define-macro (letrec* . args) + `(letrec ,@args)) + +(define-macro (do bindings finish . body) + `(let loop ,(map (lambda (x) + (list (car x) (cadr x))) + bindings) + (if ,(car finish) + (begin ,@body + (loop ,@(map (lambda (x) + (if (null? (cddr x)) + (car x) + (car (cddr x)))) + bindings))) + (begin ,@(cdr finish))))) + +(define-macro (when test . exprs) + (list 'if test (cons 'begin exprs) #f)) + +(define-macro (unless test . exprs) + (list 'if test #f (cons 'begin exprs))) + +(define (every pred list) + (if (null? list) + #t + (if (pred (car list)) + (every pred (cdr list)) + #f))) + +(define (fold f s xs) + (if (null? xs) + s + (fold f (f (car xs) s) (cdr xs)))) + +(define (values . args) + (if (and (pair? args) + (null? (cdr args))) + (car args) + (cons '*values-tag* args))) + +(define (call-with-values producer consumer) + (let ((res (producer))) + (if (and (pair? res) + (eq? '*values-tag* (car res))) + (apply consumer (cdr res)) + (consumer res)))) + +;;; 6.2. Numbers + (define (zero? n) (= n 0)) @@ -47,6 +215,30 @@ (define (even? n) (= 1 (floor-remainder n 2))) +(define (min x . args) + (let loop ((pivot x) (rest args)) + (if (null? rest) + pivot + (loop (if (< x (car rest)) x (car rest)) (cdr rest))))) + +(define (max x . args) + (let loop ((pivot x) (rest args)) + (if (null? rest) + pivot + (loop (if (> x (car rest)) x (car rest)) (cdr rest))))) + +(define (floor/ n m) + (values (floor-quotient n m) + (floor-remainder n m))) + +(define (truncate/ n m) + (values (truncate-quotient n m) + (truncate-remainder n m))) + +(define (exact-integer-sqrt k) + (let ((n (exact (sqrt k)))) + (values n (- k (square n))))) + (define (gcd n m) (if (negative? n) (set! n (- n))) @@ -64,20 +256,13 @@ (define (lcm n m) (/ (* n m) (gcd n m))) -(define (caar p) - (car (car p))) +;;; 6.3 Booleans -(define (cadr p) - (car (cdr p))) +(define (boolean=? . objs) + (or (every (lambda (x) (eq? x #t)) objs) + (every (lambda (x) (eq? x #f)) objs))) -(define (cdar p) - (cdr (car p))) - -(define (cddr p) - (cdr (cdr p))) - -(define (list . args) - args) +;;; 6.4 Pairs and lists (define (list? obj) (if (null? obj) @@ -99,12 +284,6 @@ 0 (+ 1 (length (cdr list))))) -(define (append xs ys) - (if (null? xs) - ys - (cons (car xs) - (append (cdr xs) ys)))) - (define (reverse list . args) (if (null? args) (reverse list '()) @@ -158,140 +337,6 @@ (cons (car obj) (list-copy (cdr obj))))) -(define (every pred list) - (if (null? list) - #t - (if (pred (car list)) - (every pred (cdr list)) - #f))) - -(define (any pred list) - (if (null? list) - #f - ((lambda (it) - (if it - it - (any pred (cdr list)))) - (pred (car list))))) - -(define (fold f s xs) - (if (null? xs) - s - (fold f (f (car xs) s) (cdr xs)))) - -(define (map f list . lists) - (define (single-map f list) - (if (null? list) - '() - (cons (f (car list)) - (map f (cdr list))))) - (define (multiple-map f lists) - (if (any null? lists) - '() - (cons (apply f (single-map car lists)) - (multiple-map f (single-map cdr lists))))) - (if (null? lists) - (single-map f list) - (multiple-map f (cons list lists)))) - -(define (for-each f list . lists) - (define (single-for-each f list) - (if (null? list) - #f - (begin - (f (car list)) - (single-for-each f (cdr list))))) - (define (multiple-for-each f lists) - (if (any null? lists) - #f - (begin - (apply f (map car lists)) - (multiple-for-each f (map cdr lists))))) - (if (null? lists) - (single-for-each f list) - (multiple-for-each f (cons list lists)))) - -(define-macro (let bindings . body) - (if (symbol? bindings) - (begin - (define name bindings) - (set! bindings (car body)) - (set! body (cdr body)) - ;; expanded form should be like below: - ;; `(let () - ;; (define ,loop - ;; (lambda (,@vars) - ;; ,@body)) - ;; (,loop ,@vals)) - (list 'let '() - (list 'define name - (cons 'lambda (cons (map car bindings) body))) - (cons name (map cadr bindings)))) - (cons (cons 'lambda (cons (map car bindings) body)) - (map cadr bindings)))) - -(define-macro (cond . clauses) - (if (null? clauses) - #f - (let ((c (car clauses))) - (let ((test (car c)) - (if-true (cons 'begin (cdr c))) - (if-false (cons 'cond (cdr clauses)))) - (list 'if test if-true if-false))))) - -(define-macro (and . exprs) - (if (null? exprs) - #t - (let ((test (car exprs)) - (if-true (cons 'and (cdr exprs)))) - (list 'if test if-true #f)))) - -(define-macro (or . exprs) - (if (null? exprs) - #f - (let ((test (car exprs)) - (if-false (cons 'or (cdr exprs)))) - (list 'let (list (list 'it test)) - (list 'if 'it 'it if-false))))) - -(define-macro (quasiquote x) - (cond - ((symbol? x) (list 'quote x)) - ((pair? x) - (cond - ((eq? 'unquote (car x)) (cadr x)) - ((and (pair? (car x)) - (eq? 'unquote-splicing (caar x))) - (list 'append (cadr (car x)) (list 'quasiquote (cdr x)))) - (#t (list 'cons - (list 'quasiquote (car x)) - (list 'quasiquote (cdr x)))))) - (#t x))) - -(define-macro (let* bindings . body) - (if (null? bindings) - `(let () ,@body) - `(let ((,(caar bindings) - ,@(cdar bindings))) - (let* (,@(cdr bindings)) - ,@body)))) - -(define-macro (letrec bindings . body) - (let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) - (initials (map (lambda (v) `(set! ,@v)) bindings))) - `(let (,@vars) - (begin ,@initials) - ,@body))) - -(define-macro (letrec* . args) - `(letrec ,@args)) - -(define-macro (when test . exprs) - (list 'if test (cons 'begin exprs) #f)) - -(define-macro (unless test . exprs) - (list 'if test #f (cons 'begin exprs))) - (define (member obj list . opts) (let ((compare (if (null? opts) equal? (car opts)))) (if (null? list) @@ -308,64 +353,6 @@ (car list) (assoc obj (cdr list) compare))))) -(define (values . args) - (if (and (pair? args) - (null? (cdr args))) - (car args) - (cons '*values-tag* args))) - -(define (call-with-values producer consumer) - (let ((res (producer))) - (if (and (pair? res) - (eq? '*values-tag* (car res))) - (apply consumer (cdr res)) - (consumer res)))) - -(define-macro (do bindings finish . body) - `(let loop ,(map (lambda (x) - (list (car x) (cadr x))) - bindings) - (if ,(car finish) - (begin ,@body - (loop ,@(map (lambda (x) - (if (null? (cddr x)) - (car x) - (car (cddr x)))) - bindings))) - (begin ,@(cdr finish))))) - -;;; 6.2. Numbers - -(define (min x . args) - (let loop ((pivot x) (rest args)) - (if (null? rest) - pivot - (loop (if (< x (car rest)) x (car rest)) (cdr rest))))) - -(define (max x . args) - (let loop ((pivot x) (rest args)) - (if (null? rest) - pivot - (loop (if (> x (car rest)) x (car rest)) (cdr rest))))) - -(define (floor/ n m) - (values (floor-quotient n m) - (floor-remainder n m))) - -(define (truncate/ n m) - (values (truncate-quotient n m) - (truncate-remainder n m))) - -(define (exact-integer-sqrt k) - (let ((n (exact (sqrt k)))) - (values n (- k (square n))))) - -;;; 6.3 Booleans - -(define (boolean=? . objs) - (or (every (lambda (x) (eq? x #t)) objs) - (every (lambda (x) (eq? x #f)) objs))) - ;;; 6.5. Symbols (define (symbol=? . objs) @@ -559,6 +546,23 @@ ;;; 6.10 control features +(define (for-each f list . lists) + (define (single-for-each f list) + (if (null? list) + #f + (begin + (f (car list)) + (single-for-each f (cdr list))))) + (define (multiple-for-each f lists) + (if (any null? lists) + #f + (begin + (apply f (map car lists)) + (multiple-for-each f (map cdr lists))))) + (if (null? lists) + (single-for-each f list) + (multiple-for-each f (cons list lists)))) + (define (string-map f v . vs) (let* ((len (fold min (string-length v) (map string-length vs))) (vec (make-string len)))