Changeset 33696 in project


Ignore:
Timestamp:
10/04/16 13:06:41 (5 years ago)
Author:
juergen
Message:

removed bugs with adjacent holes and replaced regexes

Location:
release/4/holes
Files:
8 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/holes/tags/1.1/holes.meta

    r33666 r33696  
    22
    33((synopsis
    4    "local expressions as procedures with named parameters")
     4   "partial expressions as procedures with named parameters")
    55 (category lang-exts)
    66 (license "BSD")
  • release/4/holes/tags/1.1/holes.scm

    r33666 r33696  
    4848]|#
    4949
    50 (require-library irregex)
    51 
    5250(module holes (->proc holes)
    5351  (import scheme
    5452          (only chicken print set-sharp-read-syntax!))
    5553
    56 (import-for-syntax
    57   (only chicken foldr)
    58   (only irregex sre->irregex irregex-extract)
    59   (only data-structures ->string))
    60 
    6154(define-syntax ->proc
    6255  (er-macro-transformer
    6356    (lambda (form rename compare?)
    64       (let ((code (cdr form))
    65             (%lambda (rename 'lambda)))
    66         (let ((irx (sre->irregex
    67                      '(: (or space "(")
    68                          "!"
    69                          (* (/ "09"))
    70                          "!"
    71                          (or space ")"))))
    72 ;              (foldr (lambda (op acc lst)
    73 ;                       (let loop ((lst lst))
    74 ;                         (if (null? lst)
    75 ;                           acc
    76 ;                           (op (car lst)
    77 ;                               (loop (cdr lst)))))))
    78               (adjoin (lambda (sym syms)
    79                         (if (memq sym syms)
    80                           syms
    81                           (cons sym syms))))
    82               )
     57      (let (
     58        (code (cdr form))
     59        (%lambda (rename 'lambda))
     60        (flatten*
     61          ; imported flatten doesn't work with pseudo-lists
     62          (lambda (tree)
     63            (let loop ((tree tree) (result '()))
     64              (cond
     65                ((pair? tree)
     66                 (loop (car tree) (loop (cdr tree) result)))
     67                ((null? tree) result)
     68                (else
     69                  (cons tree result))))))
     70        (hole?
     71          (lambda (sym)
     72            (and (symbol? sym)
     73                 (let* ((lst (string->list (symbol->string sym)))
     74                        (len (length lst))
     75                        (target (string->list "0123456789")))
     76                   (and (char=? (car lst) #\!)
     77                        (char=? (list-ref lst (fx- len 1)) #\!)
     78                        (let loop ((k 1) (result #t))
     79                          (call/cc
     80                            (lambda (out)
     81                              (if (fx= k (fx- len 1))
     82                                result
     83                                (loop (fx+ k 1)
     84                                      (if (memq (list-ref lst k)
     85                                                target)
     86                                        result
     87                                        (out #f))))))))))))
     88        (filter
     89          (lambda (ok? lst)
     90            (compress (map ok? lst) lst)))
     91        (remove-dups
     92          (lambda (syms)
     93            (let loop ((syms syms) (result '()))
     94              (cond
     95                ((null? syms)
     96                 (reverse result))
     97                ((memq (car syms) result)
     98                 (loop (cdr syms) result))
     99                (else (loop (cdr syms) (cons (car syms) result)))))))
     100          )
    83101          `(,%lambda
    84              ,(foldr adjoin '() ; remove dups
    85                      (map string->symbol
    86                           (map (lambda (str)
    87                                  (substring str 1 (- (string-length str) 1)))
    88                                (irregex-extract irx (->string code)))))
    89              ,@code))))))
     102             ,(remove-dups (filter hole? (flatten* code)))
     103             ,@code)))))
    90104
    91105(set-sharp-read-syntax! #\#
     
    96110    (list "->proc"
    97111          "macro:"
    98           "(->proc xpr)"
     112          "(->proc code)"
    99113          "  extracts holes, i.e. a pair of bangs"
    100114          "  possible enclosing a seqence of digits"
    101           "  form xpr, removes duplicates, and uses"
    102           "  the resulting list as arbument list of"
    103           "  a procedure with body xpr"
    104           "  can be called with sharp-read-syntax ##")))
     115          "  form code, removes duplicates, and uses"
     116          "  the resulting list as argument list of"
     117          "  a procedure with body code."
     118          "  Can be called with sharp-read-syntax ##")))
    105119
    106120) ; module holes
  • release/4/holes/tags/1.1/holes.setup

    r33666 r33696  
    77 'holes
    88 '("holes.so" "holes.import.so")
    9  '((version "1.0")))
     9 '((version "1.1")))
    1010
  • release/4/holes/tags/1.1/tests/run.scm

    r33666 r33696  
    2828    (equal? (##(list 1 2 (vector 3 4 !! 6)) 5)
    2929            '(1 2 #(3 4 5 6)))
    30     (equal? (##(list 1 2 #(3 4 !! 6)) 5) ; note that the third arg is quoted
     30    (equal? (##(list 1 2 #(3 4 !! 6)))
     31            ; note that the third arg of list is quoted
     32            ; hence there are no holes
    3133            '(1 2 #(3 4 !! 6)))
    3234    (equal? (##(vector 1 2 !!) 3)
     
    3840    (equal? (##(list 1 !! 2 (vector !!)) 3)
    3941            '(1 3 2 #(3)))
     42    (equal? (##(list !! !1! 2 (vector !!)) 1 2)
     43            '(1 2 2 #(1)))
    4044  ))
    4145
  • release/4/holes/trunk/holes.meta

    r33666 r33696  
    22
    33((synopsis
    4    "local expressions as procedures with named parameters")
     4   "partial expressions as procedures with named parameters")
    55 (category lang-exts)
    66 (license "BSD")
  • release/4/holes/trunk/holes.scm

    r33666 r33696  
    4848]|#
    4949
    50 (require-library irregex)
    51 
    5250(module holes (->proc holes)
    5351  (import scheme
    5452          (only chicken print set-sharp-read-syntax!))
    5553
    56 (import-for-syntax
    57   (only chicken foldr)
    58   (only irregex sre->irregex irregex-extract)
    59   (only data-structures ->string))
    60 
    6154(define-syntax ->proc
    6255  (er-macro-transformer
    6356    (lambda (form rename compare?)
    64       (let ((code (cdr form))
    65             (%lambda (rename 'lambda)))
    66         (let ((irx (sre->irregex
    67                      '(: (or space "(")
    68                          "!"
    69                          (* (/ "09"))
    70                          "!"
    71                          (or space ")"))))
    72 ;              (foldr (lambda (op acc lst)
    73 ;                       (let loop ((lst lst))
    74 ;                         (if (null? lst)
    75 ;                           acc
    76 ;                           (op (car lst)
    77 ;                               (loop (cdr lst)))))))
    78               (adjoin (lambda (sym syms)
    79                         (if (memq sym syms)
    80                           syms
    81                           (cons sym syms))))
    82               )
     57      (let (
     58        (code (cdr form))
     59        (%lambda (rename 'lambda))
     60        (flatten*
     61          ; imported flatten doesn't work with pseudo-lists
     62          (lambda (tree)
     63            (let loop ((tree tree) (result '()))
     64              (cond
     65                ((pair? tree)
     66                 (loop (car tree) (loop (cdr tree) result)))
     67                ((null? tree) result)
     68                (else
     69                  (cons tree result))))))
     70        (hole?
     71          (lambda (sym)
     72            (and (symbol? sym)
     73                 (let* ((lst (string->list (symbol->string sym)))
     74                        (len (length lst))
     75                        (target (string->list "0123456789")))
     76                   (and (char=? (car lst) #\!)
     77                        (char=? (list-ref lst (fx- len 1)) #\!)
     78                        (let loop ((k 1) (result #t))
     79                          (call/cc
     80                            (lambda (out)
     81                              (if (fx= k (fx- len 1))
     82                                result
     83                                (loop (fx+ k 1)
     84                                      (if (memq (list-ref lst k)
     85                                                target)
     86                                        result
     87                                        (out #f))))))))))))
     88        (filter
     89          (lambda (ok? lst)
     90            (compress (map ok? lst) lst)))
     91        (remove-dups
     92          (lambda (syms)
     93            (let loop ((syms syms) (result '()))
     94              (cond
     95                ((null? syms)
     96                 (reverse result))
     97                ((memq (car syms) result)
     98                 (loop (cdr syms) result))
     99                (else (loop (cdr syms) (cons (car syms) result)))))))
     100          )
    83101          `(,%lambda
    84              ,(foldr adjoin '() ; remove dups
    85                      (map string->symbol
    86                           (map (lambda (str)
    87                                  (substring str 1 (- (string-length str) 1)))
    88                                (irregex-extract irx (->string code)))))
    89              ,@code))))))
     102             ,(remove-dups (filter hole? (flatten* code)))
     103             ,@code)))))
    90104
    91105(set-sharp-read-syntax! #\#
     
    96110    (list "->proc"
    97111          "macro:"
    98           "(->proc xpr)"
     112          "(->proc code)"
    99113          "  extracts holes, i.e. a pair of bangs"
    100114          "  possible enclosing a seqence of digits"
    101           "  form xpr, removes duplicates, and uses"
    102           "  the resulting list as arbument list of"
    103           "  a procedure with body xpr"
    104           "  can be called with sharp-read-syntax ##")))
     115          "  form code, removes duplicates, and uses"
     116          "  the resulting list as argument list of"
     117          "  a procedure with body code."
     118          "  Can be called with sharp-read-syntax ##")))
    105119
    106120) ; module holes
  • release/4/holes/trunk/holes.setup

    r33666 r33696  
    77 'holes
    88 '("holes.so" "holes.import.so")
    9  '((version "1.0")))
     9 '((version "1.1")))
    1010
  • release/4/holes/trunk/tests/run.scm

    r33666 r33696  
    2828    (equal? (##(list 1 2 (vector 3 4 !! 6)) 5)
    2929            '(1 2 #(3 4 5 6)))
    30     (equal? (##(list 1 2 #(3 4 !! 6)) 5) ; note that the third arg is quoted
     30    (equal? (##(list 1 2 #(3 4 !! 6)))
     31            ; note that the third arg of list is quoted
     32            ; hence there are no holes
    3133            '(1 2 #(3 4 !! 6)))
    3234    (equal? (##(vector 1 2 !!) 3)
     
    3840    (equal? (##(list 1 !! 2 (vector !!)) 3)
    3941            '(1 3 2 #(3)))
     42    (equal? (##(list !! !1! 2 (vector !!)) 1 2)
     43            '(1 2 2 #(1)))
    4044  ))
    4145
Note: See TracChangeset for help on using the changeset viewer.