Changeset 35223 in project


Ignore:
Timestamp:
02/25/18 23:25:20 (10 months ago)
Author:
kon
Message:

expand vector , condition on proper-list , better csi help message . use csi+csc test runner
-This line, and those below, will be ignored--

M expand-full/trunk/expand-full.scm
M expand-full/trunk/expand-full.setup
A expand-full/trunk/tests/expand-full-test.scm
M expand-full/trunk/tests/run.scm

Location:
release/4/expand-full/trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/expand-full/trunk/expand-full.scm

    r18913 r35223  
    66(module expand-full
    77
    8   (;export
    9     expand*
    10     pretty-print-expand*
    11     ppexpand*)
     8(;export
     9  expand*
     10  pretty-print-expand* ppexpand*)
    1211
    13   (import
    14     scheme
    15     chicken
    16     (only csi toplevel-command)
    17     (only extras pretty-print)
    18     (only srfi-1 map!))
    19  
    20   (require-library extras srfi-1)
    21 
    22 ;;;
     12(import
     13  scheme chicken
     14  (only csi toplevel-command))
     15(use
     16  (only data-structures o atom?)
     17  (only extras pretty-print)
     18  (only srfi-1 proper-list? map!)
     19  (only vector-lib vector-map))
    2320
    2421;;
    2522
     23(: expand (* #!optional * --> *))
     24;
    2625(define (expand* form #!optional se)
    27   (let expd ((form form))
    28     (let ((form*
    29             (cond
    30               ((list? form)
    31                 (let ((form* (expand form se)))
    32                   (if (not (list? form*)) form*
    33                       (map! expd form*) ) ) )
    34               ((pair? form)
    35                 (cons (expd (car form)) (expd (cdr form))) )
    36               (else
    37                 (expand form se) ) ) ) )
    38       (if (equal? form form*) form
    39           (expd form*) ) ) ) )
     26  (let expand-loop ((form form))
     27    (let (
     28      (expanded
     29        (cond
     30          ((null? form)
     31            '() )
     32          ((proper-list? form)
     33            (let ((expanded (expand form se)))
     34              (if (not (proper-list? expanded))
     35                expanded
     36                (map! expand-loop expanded) ) ) )
     37          ((pair? form)
     38            (cons (expand-loop (car form)) (expand-loop (cdr form))) )
     39          ((vector? form)
     40            (vector-map (lambda (_ x) (expand-loop x)) form) )
     41          (else
     42            form ) ) ) )
     43      (if (equal? form expanded)
     44        form
     45        (expand-loop expanded) ) ) ) )
     46
     47#; ;WTF
     48(define (expand* form #!optional se going-up?)
     49  ;
     50  (: protected? (* --> boolean))
     51  ;
     52  (define (protected? obj)
     53    (or (null? obj) (atom? obj) (not (proper-list? obj))) )
     54
     55  (: protected-expand (* #!optional * --> *))
     56  ;
     57  (define (protected-expand form #!optional se)
     58    (if (protected? form)
     59      form
     60      (expand form se)) )
     61
     62  (: protected-equal=? (* * --> boolean))
     63  ;
     64  (define (protected-equal=? a b)
     65    (or
     66      (and (not (number? a)) (protected? a))
     67      (and (not (number? b)) (protected? b))
     68      (equal=? a b)) )
     69  ;
     70  (let expand*-loop ((form form))
     71    ;
     72    (define (seq-expand form)
     73      (cond
     74        ((pair? form)
     75          (cons (expand*-loop (car form)) (expand*-loop (cdr form))) )
     76        ((list? form)
     77          (map expand*-loop form) )
     78        ((vector? form)
     79          (vector-map (lambda (_ x) (expand*-loop x)) form) )
     80        (else
     81          form ) ) )
     82    ;
     83    ;(define local-protected-expand (o strip-syntax (cut protected-expand <> se)))
     84    (define local-protected-expand (cut protected-expand <> se))
     85    ;
     86    (define bottom-up (o local-protected-expand seq-expand))
     87    (define top-down (o seq-expand local-protected-expand))
     88    (define go-direction (if going-up? bottom-up top-down))
     89    ;
     90    (let ((expanded (go-direction form)))
     91      (if (protected-equal=? form expanded)
     92        form
     93        (expand*-loop expanded) ) ) ) )
    4094
    4195;;
    4296
     97(: pretty-print-expand* (* #!optional * --> *))
     98;
    4399(define (pretty-print-expand* form #!optional se)
    44100  (pretty-print (strip-syntax (expand* form se)))
    45101  (void) )
    46102
     103(: ppexpand* (* #!optional * --> *))
     104;
    47105(define ppexpand* pretty-print-expand*)
    48106
    49107;;;
    50108
    51 (when (feature? csi:)
     109(when (feature? 'csi)
    52110  (toplevel-command 'x*
     111    ;FIXME need apropos like csi argument handler
    53112    (lambda () (ppexpand* (read)))
    54     ",x* EXP           Pretty print fully expanded expression EXP") )
     113    ",x* EXP           Pretty print, almost fully, expanded expression EXP") )
    55114
    56115) ;module expand-full
  • release/4/expand-full/trunk/expand-full.setup

    r33409 r35223  
    55(verify-extension-name "expand-full")
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "1.0.3")
     7(setup-shared-extension-module (extension-name) (extension-version "1.0.4")
    88  #:compile-options '(
    99    -scrutinize
  • release/4/expand-full/trunk/tests/run.scm

    r18913 r35223  
    1 (require-extension expand-full)
    21
    3 (define-syntax stream-match-pattern
    4   (syntax-rules (_)
    5     ((stream-match-pattern STRM () (BINDING ...) BODY)
    6      (and (stream-null? STRM) (let (BINDING ...) BODY)))
    7     ((stream-match-pattern STRM (_ . REST) (BINDING ...) BODY)
    8      (and (stream-pair? STRM)
    9           (let ((STRM (stream-cdr STRM)))
    10             (stream-match-pattern STRM REST (BINDING ...) BODY))))
    11     ((stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
    12      (and (stream-pair? STRM)
    13           (let ((temp (stream-car STRM)) (STRM (stream-cdr STRM)))
    14             (stream-match-pattern STRM REST ((VAR temp) BINDING ...) BODY))))
    15     ((stream-match-pattern STRM _ (BINDING ...) BODY)
    16      (let (BINDING ...) BODY))
    17     ((stream-match-pattern STRM VAR (BINDING ...) BODY)
    18      (let ((VAR STRM) BINDING ...) BODY))))
     2(define EGG-NAME "expand-full")
    193
    20 (define-syntax stream-match-test
    21   (syntax-rules ()
    22     ((stream-match-test STRM (PATTERN FENDER EXPR))
    23      (stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))))
    24     ((stream-match-test STRM (PATTERN EXPR))
    25      (stream-match-pattern STRM PATTERN () (list EXPR)))))
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    265
    27 (define-syntax stream-match
    28   (syntax-rules ()
    29     ((stream-match STRM-EXPR CLAUSE ...)
    30      (let ((strm STRM-EXPR))
    31        (cond ((not (stream? strm)) (error-invalid-stream 'stream-match strm))
    32              ((stream-match-test strm CLAUSE) => car) ...
    33              (else (error 'stream-match "pattern failure")))))))
     6(use files)
    347
    35 (ppexpand*
    36   '(stream-match yy
    37     (() (stream (stream x)))
    38     ((y . ys)
    39       (stream-append
    40         (stream (stream-cons x yy))
    41         (stream-map (lambda (z) (stream-cons y z))
    42                     (stream-intersperse ys x))))) )
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    4310
    44 (ppexpand*  '(and a b))
     11(define *args* (argv))
     12
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
     15
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
     24
     25;;;
     26
     27(set! EGG-NAME (egg-name))
     28
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
     37
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
     40
     41;;;
     42
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.