From 1f6493cb3d1731d6fb94fea12c36a18b2162fd63 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 31 Mar 2009 13:57:50 +0900 Subject: [PATCH] more primitives --- init.scm | 61 ++++++++++------ syntax-rules.scm | 177 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 215 insertions(+), 23 deletions(-) create mode 100644 syntax-rules.scm diff --git a/init.scm b/init.scm index 31811903..95ea7c97 100644 --- a/init.scm +++ b/init.scm @@ -1,35 +1,31 @@ -;; define set! let let* letrec lambda if cond case delay and or begin do -;; quote quasiquote unquote unquote-splicing define-syntax let-syntax -;; letrec-syntax syntax-rules eqv? eq? equal? not boolean? number? -;; complex? real? rational? integer? exact? inexact? = < > <= >= zero? -;; positive? negative? odd? even? max min + * - / abs quotient remainder -;; modulo gcd lcm numerator denominator floor ceiling truncate round -;; rationalize exp log sin cos tan asin acos atan sqrt expt +;; let* cond case delay and do +;; quasiquote unquote unquote-splicing let-syntax +;; letrec-syntax syntax-rules eqv? equal? not boolean? number? +;; complex? real? rational? integer? exact? inexact? +;; positive? negative? odd? even? max min quotient remainder +;; modulo numerator denominator floor ceiling truncate round +;; rationalize sqrt expt ;; make-rectangular make-polar real-part imag-part magnitude angle -;; exact->inexact inexact->exact number->string string->number pair? cons -;; car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr -;; cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr -;; caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr -;; null? list? list length append reverse list-tail list-ref memq memv -;; member assq assv assoc symbol? symbol->string string->symbol char? -;; char=? char? char<=? char>=? char-ci=? char-ci? -;; char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? +;; exact->inexact inexact->exact number->string string->number +;; list? list-tail list-ref memv +;; member assv assoc symbol->string string->symbol +;; char-alphabetic? char-numeric? char-whitespace? ;; char-upper-case? char-lower-case? char->integer integer->char -;; char-upcase char-downcase string? make-string string string-length -;; string-ref string-set! string=? string-ci=? string? +;; char-upcase char-downcase make-string string string-length +;; string=? string-ci=? string? ;; string<=? string>=? string-ci? string-ci<=? string-ci>=? ;; substring string-append string->list list->string string-copy -;; string-fill! vector? make-vector vector vector-length vector-ref -;; vector-set! vector->list list->vector vector-fill! procedure? apply +;; string-fill! make-vector vector vector-length +;; vector->list list->vector vector-fill! procedure? apply ;; map for-each force call-with-current-continuation values ;; call-with-values dynamic-wind scheme-report-environment ;; null-environment call-with-input-file call-with-output-file -;; input-port? output-port? current-input-port current-output-port +;; current-input-port current-output-port ;; with-input-from-file with-output-to-file open-input-file -;; open-output-file close-input-port close-output-port read read-char -;; peek-char eof-object? char-ready? write display newline write-char -;; load eval +;; open-output-file close-input-port close-output-port +;; peek-char eof-object? char-ready? +;; eval ;; provide c[ad]{2,4}r @@ -143,6 +139,25 @@ 'tmp (make-syntactic-closure use-env '() (cons 'or (cddr expr)))))))))) +;; char utils + +;; (define (char=? a b) (= (char->integer a) (char->integer b))) +;; (define (charinteger a) (char->integer b))) +;; (define (char>? a b) (> (char->integer a) (char->integer b))) +;; (define (char<=? a b) (<= (char->integer a) (char->integer b))) +;; (define (char>=? a b) (>= (char->integer a) (char->integer b))) + +;; (define (char-ci=? a b) +;; (= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +;; (define (char-ciinteger (char-downcase a)) (char->integer (char-downcase b)))) +;; (define (char-ci>? a b) +;; (> (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +;; (define (char-ci<=? a b) +;; (<= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +;; (define (char-ci>=? a b) +;; (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) + ;; math ;; (define (abs x) (if (< x 0) (- x) x)) diff --git a/syntax-rules.scm b/syntax-rules.scm new file mode 100644 index 00000000..687b5384 --- /dev/null +++ b/syntax-rules.scm @@ -0,0 +1,177 @@ + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((lits (cadr expr)) + (forms (cddr expr)) + (count 0) + (_er-macro-transformer (rename 'er-macro-transformer)) + (_lambda (rename 'lambda)) (_let (rename 'let)) + (_begin (rename 'begin)) (_if (rename 'if)) + (_and (rename 'and)) (_or (rename 'or)) + (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) + (_car (rename 'car)) (_cdr (rename 'cdr)) + (_cons (rename 'cons)) (_pair? (rename 'pair?)) + (_null? (rename 'null?)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_quote (rename 'quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define (next-v) + (set! count (+ count 1)) + (rename (string->symbol (string-append "v." (number->string count))))) + (define (expand-pattern pat tmpl) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) + (dim 0) + (vars '()) + (k (lambda (vars) + (or (expand-template tmpl vars) + (list _begin #f))))) + (let ((v (next-v))) + (list + _let (list (list v x)) + (cond + ((symbol? p) + (if (memq p lits) + (list _and (list _eq? v p) (k vars)) + (list _let (list (list p v)) (k (cons (cons p dim) vars))))) + ((ellipse? p) + (cond + ((not (null? (cddr p))) + (error "non-trailing ellipse" p)) + ((symbol? (car p)) + (list _and (list _list? v) + (list _let (list (list (car p) v)) + (k (cons (cons (car p) (+ 1 dim)) vars))))) + (else + (let* ((w (next-v)) + (new-vars (all-vars (car p) (+ dim 1))) + (ls-vars (map (lambda (x) + (rename (string->symbol + (string-append + (symbol->string (car x)) + "-ls")))) + new-vars)) + (once + (lp (car p) (list _car w) (+ dim 1) '() + (lambda (_) + (cons + _lp + (cons + (list _cdr w) + (map (lambda (x l) + (list _cons (car x) l)) + new-vars + ls-vars))))))) + (list + _let + _lp (list (list w v) + (map (lambda (x) (list x '())) ls-vars)) + (list _if (list _null? w) + (list _let (map (lambda (x l) + (list (car x) (list _reverse l))) + new-vars + ls-vars) + (k (append new-vars vars))) + (list _and (list _pair? w) once))))))) + ((pair? p) + (list _and (list _pair? v) + (lp (car p) + (list _car v) + dim + vars + (lambda (vars) + (lp (cdr p) (list _cdr v) dim vars k))))) + ((vector? p) + (list _and + (list _vector? v) + (lp (vector->list p) (list _vector->list v) dim vars k))) + ((null? p) (list _and (list _null? v) (k vars))) + (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (eq? '... (cadr x)))) + (define (ellipse-depth x) + (if (ellipse? x) + (+ 1 (ellipse-depth (cdr x))) + 0)) + (define (ellipse-tail x) + (if (ellipse? x) + (ellipse-tail (cdr x)) + (cdr x))) + (define (all-vars x dim) + (let lp ((x x) (dim dim) (vars '())) + (cond ((symbol? x) (if (memq x lits) vars (cons (cons x dim) vars))) + ((ellipse? x) (lp (car x) (+ dim 1) vars)) + ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) + ((vector? x) (lp (vector->list x) dim vars)) + (else vars)))) + (define (free-vars x vars dim) + (let lp ((x x) (free '())) + (cond ((symbol? x) + (if (and (not (memq x free)) + (cond ((assq x vars) + => (lambda (cell) (>= (cdr cell) dim))) + (else #f))) + (cons x free) + free)) + ((pair? x) (free-vars (car x) (free-vars (cdr x) free))) + ((vector? x) (lp (vector->list x) free)) + (else free)))) + (define (expand-template tmpl vars) + (let lp ((t tmpl) (dim 0)) + (cond + ((symbol? t) + (cond + ((assq t vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s for" t tmpl)))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (if (ellipse? t) + (let* ((depth (ellipse-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (if (null? ell-vars) + (error "too many ...'s" tmpl t) + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (symbol? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipse-tail t)) + many ;; shortcut + (list _append many (lp (ellipse-tail t) dim)))))) + (list _cons (lp (car t) dim) (lp (cdr t) dim)))) + ((vector? t) (list _list->vector (lp (vector->list t) dim))) + ((null? t) (list _quote '())) + (else t)))) + (list + _er-macro-transformer + (list _lambda (list _expr _rename _compare) + (cons + _or + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (error "no expansion for" _expr)))))))) + +;; Local Variables: +;; eval: (put '_lambda 'scheme-indent-function 1) +;; eval: (put '_let 'scheme-indent-function 'scheme-let-indent) +;; eval: (put '_if 'scheme-indent-function 3) +;; End: +