Changeset 39062 in project
- Timestamp:
- 10/19/20 21:58:28 (4 months ago)
- Location:
- release/5/expand-full/trunk
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
release/5/expand-full/trunk/expand-full.egg
r39042 r39062 7 7 (author "[[kon lovett]]") 8 8 (license "BSD") 9 (dependencies srfi-1 vector-lib)9 (dependencies srfi-1) 10 10 (test-dependencies test) 11 11 (components -
release/5/expand-full/trunk/expand-full.scm
r39042 r39062 1 ;;;; expand-full.scm -*- Scheme -*- 1 ;;;; expand-full.scm -*- scheme -*- 2 ;;;; Kon Lovett, Oct '20 2 3 ;;;; Kon Lovett, Sep '19 3 4 ;;;; Kon Lovett, Jul '18 4 5 ;;;; Kon Lovett, Apr '09 5 6 6 ;; Issues7 ;;8 ;; - depth vs breadth9 10 7 (module expand-full 11 8 12 9 (;export 13 ;14 expandable?15 expand-if16 expand-depth depth17 expand-breadth breadth18 ;19 10 expand* 20 11 pretty-print-expand* ppexpand*) … … 27 18 (import (only (chicken pretty-print) pretty-print)) 28 19 (import (only (srfi 1) proper-list?)) 29 (import (only vector-lib vector-map))30 20 31 21 ;; 32 22 33 (define (safe-list-map func form) 34 (let ((1st (func (car form)))) 35 (if (null? (cdr form)) 36 1st 37 (cons 1st (func (cdr form)))) ) ) 38 39 (define (across func form) 40 (cond 41 ((vector? form) 42 (vector-map (lambda (_ x) (func x)) form)) 43 ((pair? form) 44 (print "across " form) 45 (if (or (eq? 'quote (car form)) (eq? '##core#quote (car form))) 46 form 47 (safe-list-map func form))) 48 (else 49 form)) ) 50 51 (define (down stpr form expanded) 52 (let loop ((form form) (expanded expanded)) 53 (if (equal? form expanded) 54 form 55 (loop expanded (across stpr expanded)) ) ) ) 56 57 (define (breadth xpdr form) (down (cut breadth xpdr <>) form (xpdr (across xpdr form)))) 58 59 (define (depth xpdr form) (down (cut depth xpdr <>) form (xpdr form))) 23 (define (expand-form xpdr form) 24 (define (quote? x) (or (eq? 'quote x) (eq? '##core#quote x))) 25 ;expand 1st, then recurse 26 (let ((expd (xpdr form))) 27 (cond 28 ;empty form 29 ((null? expd) 30 expd ) 31 ;list form 32 ((proper-list? expd) 33 ;skip quoted form (skips '(1 2 ...) but ...) 34 (if (quote? (car expd)) 35 expd 36 (map (cut expand-form xpdr <>) expd) ) ) 37 ;improper list form 38 ((pair? expd) 39 (cons (expand-form xpdr (car expd)) (expand-form xpdr (cdr expd))) ) 40 ;atom 41 (else 42 expd ) ) ) ) 60 43 61 44 ;; … … 65 48 (define (expand-if form . args) (if (expandable? form) (apply expand form args) form)) 66 49 67 (define (expand-breadth form . args) (breadth (cut apply expand <> args) form)) 68 (define (expand-depth form . args) (depth (cut apply expand-if <> args) form)) 69 70 (define expand* expand-breadth) 50 (define (expand* form . args) (expand-form (cut apply expand-if <> args) form)) 71 51 72 52 ;; 73 53 74 54 (define (pretty-print-expand* form . args) 55 ;FIXME why strip-syntax on result & not input form? 75 56 (pretty-print (strip-syntax (apply expand* form args))) 76 57 (void) )
Note: See TracChangeset
for help on using the changeset viewer.