Changeset 39062 in project


Ignore:
Timestamp:
10/19/20 21:58:28 (7 weeks ago)
Author:
Kon Lovett
Message:

comment simpler form

Location:
release/5/expand-full/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/5/expand-full/trunk/expand-full.egg

    r39042 r39062  
    77 (author "[[kon lovett]]")
    88 (license "BSD")
    9  (dependencies srfi-1 vector-lib)
     9 (dependencies srfi-1)
    1010 (test-dependencies test)
    1111 (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
    23;;;; Kon Lovett, Sep '19
    34;;;; Kon Lovett, Jul '18
    45;;;; Kon Lovett, Apr '09
    56
    6 ;; Issues
    7 ;;
    8 ;; - depth vs breadth
    9 
    107(module expand-full
    118
    129(;export
    13   ;
    14   expandable?
    15   expand-if
    16   expand-depth depth
    17   expand-breadth breadth
    18   ;
    1910  expand*
    2011  pretty-print-expand* ppexpand*)
     
    2718(import (only (chicken pretty-print) pretty-print))
    2819(import (only (srfi 1) proper-list?))
    29 (import (only vector-lib vector-map))
    3020
    3121;;
    3222
    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 ) ) ) )
    6043
    6144;;
     
    6548(define (expand-if form . args) (if (expandable? form) (apply expand form args) form))
    6649
    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))
    7151
    7252;;
    7353
    7454(define (pretty-print-expand* form . args)
     55  ;FIXME why strip-syntax on result & not input form?
    7556  (pretty-print (strip-syntax (apply expand* form args)))
    7657  (void) )
Note: See TracChangeset for help on using the changeset viewer.