Changeset 14549 in project


Ignore:
Timestamp:
05/07/09 08:50:40 (11 years ago)
Author:
Ivan Raikov
Message:

srfi-42 copied to release/4 branch

Location:
release/4/srfi-42
Files:
1 deleted
4 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/srfi-42/trunk/srfi-42.meta

    r10032 r14549  
    11;;; srfi-42.meta -*- Hen -*-
    22
    3 ((date "2003-10-29")
    4  (egg "srfi-42.egg")
    5  (synopsis
    6    "SRFI-42 (Eager comprehensions)")
     3((egg "srfi-42.egg")
     4 (synopsis"SRFI-42 (Eager comprehensions)")
    75 (license "SRFI")
    8  (needs syntax-case)
     6 (needs )
    97 (category data)
    108 (doc-from-wiki)
    119 (author "Sebastian Egner")
    12  (files "srfi-42.setup" "srfi-42.scm" "srfi-42-support.scm" "srfi-42.html" "tests"))
     10 (maintainer "Ivan Raikov")
     11 (files "srfi-42.setup" "srfi-42.scm" "srfi-42.html" "tests"))
  • release/4/srfi-42/trunk/srfi-42.scm

    r12283 r14549  
    1 ;;;; srfi-42.scm
    2 
    31; <PLAINTEXT>
    42; Eager Comprehensions in [outer..inner|expr]-Convention
    53; ======================================================
    64;
    7 ; sebastian.egner@philips.com, Eindhoven, The Netherlands, 25-Apr-2005
     5; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007
    86; Scheme R5RS (incl. macros), SRFI-23 (error).
    97;
    10 ; Loading the implementation into Scheme48 0.57:
    11 ;   ,open srfi-23
    12 ;   ,load ec.scm
    13 ;
    14 ; Loading the implementation into PLT/DrScheme 202:
    15 ;   ; File > Open ... "ec.scm", click Execute
    16 ;
    17 ; Loading the implementation into SCM 5d7:
    18 ;   (require 'macro) (require 'record)
    19 ;   (load "ec.scm")
    20 ;
    21 ; Implementation comments:
    22 ;   * All local (not exported) identifiers are named ec-<something>.
    23 ;   * This implementation focuses on portability, performance,
    24 ;     readability, and simplicity roughly in this order. Design
    25 ;     decisions related to performance are taken for Scheme48.
    26 ;   * Alternative implementations, Comments and Warnings are
    27 ;     mentioned after the definition with a heading.
     8; Ported to Chicken Scheme by Ivan Raikov.
     9
     10(module srfi-42
     11
     12        ( (do-ec do-ec:do) list-ec append-ec string-ec
     13          string-append-ec vector-ec vector-of-length-ec
     14          sum-ec product-ec min-ec max-ec any?-ec
     15          every?-ec first-ec last-ec fold-ec fold3-ec
     16          :list :string (:vector ec-:vector-filter) :range :real-range
     17          :char-range :port :integers :dispatched
     18          :do :let :parallel :while :until )
     19                       
     20         
     21
     22   (import scheme chicken )
    2823
    2924
     
    5146;   ls   - loop step
    5247;   etc  - more arguments of mixed type
     48
    5349
    5450
     
    274270;           (:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
    275271;
     272; Bug #1:
    276273;    Unfortunately, this code is wrong because ne1? may depend
    277274;    in the inner bindings introduced in ilet, but ne1? is evaluated
     
    279276;    :do to see the structure.)
    280277;       The problem manifests itself (as sunnan@handgranat.org
    281 ;    observed) when the :list-generator is modified:
     278;    observed, 25-Apr-2005) when the :list-generator is modified:
    282279;
    283280;      (do-ec (:while (:list x '(1 2)) (= x 1)) (display x)).
     
    304301;               (if ne2?
    305302;                   (loop ls ...) )))))
     303;
     304; Bug #2:
     305;    Unfortunately, the above expansion is still incorrect (as Jens-Axel
     306;    Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even
     307;    if ne1?-value is #f, indicating that the loop has ended.
     308;       The problem manifests itself in the following example:
     309;
     310;      (do-ec (:while (:list x '(1)) #t) (display x))
     311;
     312;    Which iterates :list beyond exhausting the list '(1).
     313;
     314;    For the fix, we follow Jens-Axel's approach of guarding the evaluation
     315;    of ib-rhs with a check on ne1?-value.
    306316
    307317(define-syntax :while-1
     
    344354          lbs
    345355          (let ((ne1?-value ne1?))
    346             (let (ib-save ...)
    347                 ic ...
    348                 (and ne1?-value test)))
     356            (and ne1?-value
     357                 (let (ib-save ...)
     358                   ic ...
     359                   test)))
    349360          (let (ib-restore ...))
    350361          ne2?
    351362          lss))))
     363
    352364
    353365(define-syntax :until
     
    389401            (set! len (string-length str)))
    390402          ((i 0))
    391           (fx< i len)
     403          (< i len)
    392404          (let ((var (string-ref str i))))
    393405          #t
    394           ((fx+ i 1)) ))
     406          ((+ i 1)) ))
    395407    ((:string cc var (index i) arg1 arg2 arg ...)
    396408     (:string cc var (index i) (string-append arg1 arg2 arg ...)) )
     
    412424            (set! len (vector-length vec)))
    413425          ((i 0))
    414           (fx< i len)
     426          (< i len)
    415427          (let ((var (vector-ref vec i))))
    416428          #t
    417           ((fx+ i 1)) ))
     429          ((+ i 1)) ))
    418430
    419431    ((:vector cc var (index i) arg1 arg2 arg ...)
     
    425437                (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
    426438          ((k 0))
    427           (if (fx< k len)
     439          (if (< k len)
    428440              #t
    429441              (if (null? vecs)
     
    436448          (let ((var (vector-ref vec k))))
    437449          #t
    438           ((fx+ k 1)) ))))
     450          ((+ k 1)) ))))
     451
     452(define (ec-:vector-filter vecs)
     453  (if (null? vecs)
     454      '()
     455      (if (zero? (vector-length (car vecs)))
     456          (ec-:vector-filter (cdr vecs))
     457          (cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
    439458
    440459; Alternative: A simpler implementation for :vector uses vector->list
     
    467486     (:do cc
    468487          (let ((b arg2))
    469             (if (not (##core#check (and (integer? b) (exact? b))))
     488            (if (not (and (integer? b) (exact? b)))
    470489                (error
    471490                   "arguments of :range are not exact integer "
     
    480499     (:do cc
    481500          (let ((b arg2))
    482             (if (not (##core#check (and (integer? b) (exact? b))))
     501            (if (not (and (integer? b) (exact? b)))
    483502                (error
    484503                   "arguments of :range are not exact integer "
     
    493512     (:do cc
    494513          (let ((a arg1) (b arg2))
    495             (if (not (##core#check (and (integer? a) (exact? a)
    496                                         (integer? b) (exact? b) )) )
     514            (if (not (and (integer? a) (exact? a)
     515                          (integer? b) (exact? b) ))
    497516                (error
    498517                   "arguments of :range are not exact integer "
     
    507526     (:do cc
    508527          (let ((a arg1) (b arg2) (s -1) (stop 0))
    509             (if (not (##core#check (and (integer? a) (exact? a)
    510                                         (integer? b) (exact? b) )) )
     528            (if (not (and (integer? a) (exact? a)
     529                          (integer? b) (exact? b) ))
    511530                (error
    512531                   "arguments of :range are not exact integer "
     
    523542     (:do cc
    524543          (let ((a arg1) (b arg2) (s arg3) (stop 0))
    525             (if (not (##core#check (and (integer? a) (exact? a)
    526                                         (integer? b) (exact? b)
    527                                         (integer? s) (exact? s) )) )
     544            (if (not (and (integer? a) (exact? a)
     545                          (integer? b) (exact? b)
     546                          (integer? s) (exact? s) ))
    528547                (error
    529548                   "arguments of :range are not exact integer "
     
    562581     (:do cc
    563582          (let ((a arg1) (b arg2) (s arg3) (istop 0))
    564             (if (not (##core#check (and (real? a) (real? b) (real? s))))
     583            (if (not (and (real? a) (real? b) (real? s)))
    565584                (error "arguments of :real-range are not real" a b s) )
    566585            (if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
     
    586605          (let ((imax (char->integer arg2))))
    587606          ((i (char->integer arg1)))
    588           (fx<= i imax)
     607          (<= i imax)
    589608          (let ((var (integer->char i))))
    590609          #t
    591           ((fx+ i 1)) ))))
     610          ((+ i 1)) ))))
    592611
    593612; Warning: There is no R5RS-way to implement the :char-range generator
     
    629648                (empty (list #f)) )
    630649            (set! g (d args))
    631             (if (not (##core#check (procedure? g)))
     650            (if (not (procedure? g))
    632651                (error "unrecognized arguments in dispatching"
    633652                       args
     
    685704     (error "illegal macro call") )))
    686705
     706
     707(define (dispatch-union d1 d2)
     708  (lambda (args)
     709    (let ((g1 (d1 args)) (g2 (d2 args)))
     710      (if g1
     711          (if g2
     712              (if (null? args)
     713                  (append (if (list? g1) g1 (list g1))
     714                          (if (list? g2) g2 (list g2)) )
     715                  (error "dispatching conflict" args (d1 '()) (d2 '())) )
     716              g1 )
     717          (if g2 g2 #f) ))))
     718
     719
     720; ==========================================================================
     721; The dispatching generator :
     722; ==========================================================================
     723
     724(define (make-initial-:-dispatch)
     725  (lambda (args)
     726    (case (length args)
     727      ((0) 'SRFI42)
     728      ((1) (let ((a1 (car args)))
     729             (cond
     730              ((list? a1)
     731               (:generator-proc (:list a1)) )
     732              ((string? a1)
     733               (:generator-proc (:string a1)) )
     734              ((vector? a1)
     735               (:generator-proc (:vector a1)) )
     736              ((and (integer? a1) (exact? a1))
     737               (:generator-proc (:range a1)) )
     738              ((real? a1)
     739               (:generator-proc (:real-range a1)) )
     740              ((input-port? a1)
     741               (:generator-proc (:port a1)) )
     742              (else
     743               #f ))))
     744      ((2) (let ((a1 (car args)) (a2 (cadr args)))
     745             (cond
     746              ((and (list? a1) (list? a2))
     747               (:generator-proc (:list a1 a2)) )
     748              ((and (string? a1) (string? a1))
     749               (:generator-proc (:string a1 a2)) )
     750              ((and (vector? a1) (vector? a2))
     751               (:generator-proc (:vector a1 a2)) )
     752              ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
     753               (:generator-proc (:range a1 a2)) )
     754              ((and (real? a1) (real? a2))
     755               (:generator-proc (:real-range a1 a2)) )
     756              ((and (char? a1) (char? a2))
     757               (:generator-proc (:char-range a1 a2)) )
     758              ((and (input-port? a1) (procedure? a2))
     759               (:generator-proc (:port a1 a2)) )
     760              (else
     761               #f ))))
     762      ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
     763             (cond
     764              ((and (list? a1) (list? a2) (list? a3))
     765               (:generator-proc (:list a1 a2 a3)) )
     766              ((and (string? a1) (string? a1) (string? a3))
     767               (:generator-proc (:string a1 a2 a3)) )
     768              ((and (vector? a1) (vector? a2) (vector? a3))
     769               (:generator-proc (:vector a1 a2 a3)) )
     770              ((and (integer? a1) (exact? a1)
     771                    (integer? a2) (exact? a2)
     772                    (integer? a3) (exact? a3))
     773               (:generator-proc (:range a1 a2 a3)) )
     774              ((and (real? a1) (real? a2) (real? a3))
     775               (:generator-proc (:real-range a1 a2 a3)) )
     776              (else
     777               #f ))))
     778      (else
     779       (letrec ((every?
     780                 (lambda (pred args)
     781                   (if (null? args)
     782                       #t
     783                       (and (pred (car args))
     784                            (every? pred (cdr args)) )))))
     785         (cond
     786          ((every? list? args)
     787           (:generator-proc (:list (apply append args))) )
     788          ((every? string? args)
     789           (:generator-proc (:string (apply string-append args))) )
     790          ((every? vector? args)
     791           (:generator-proc (:list (apply append (map vector->list args)))) )
     792          (else
     793           #f )))))))
     794
     795(define :-dispatch
     796  (make-initial-:-dispatch) )
     797
     798(define (:-dispatch-ref)
     799  :-dispatch )
     800
     801(define (:-dispatch-set! dispatch)
     802  (if (not (procedure? dispatch))
     803      (error "not a procedure" dispatch) )
     804  (set! :-dispatch dispatch) )
     805
    687806(define-syntax :
    688807  (syntax-rules (index)
     
    794913             (i 0) )
    795914         (do-ec qualifier
    796                 (if (fx< i len)
     915                (if (< i len)
    797916                    (begin (vector-set! vec i expression)
    798                            (set! i (fx+ i 1)) )
     917                           (set! i (+ i 1)) )
    799918                    (error "vector is too short for the comprehension") ))
    800          (if (##core#check (fx= i len))
     919         (if (= i len)
    801920             vec
    802921             (error "vector is too long for the comprehension") ))))))
     
    9321051     (first-ec #t qualifier (if (not expression)) #f) )))
    9331052
     1053)
  • release/4/srfi-42/trunk/srfi-42.setup

    r12283 r14549  
    11;;; srfi-42.setup -*- Scheme -*-
    22
    3 (compile -s -O2 -d0 -R syntax-case -check-imports -emit-exports srfi-42-support.exports srfi-42-support.scm)
     3(define (dynld-name fn)         
     4  (make-pathname #f fn ##sys#load-dynamic-extension))   
     5
     6(compile -s -O2 -d0 srfi-42.scm -j srfi-42)
     7(compile -s -O2 -d0 srfi-42.import.scm)
    48
    59(install-extension
    610 'srfi-42
    7  '("srfi-42.scm" "srfi-42-support.so" "srfi-42.html")
     11 `(,(dynld-name "srfi-42") ,(dynld-name  "srfi-42.import") )
    812 '((syntax)
    9    (version 1.5)
     13   (version 1.6)
    1014   (documentation "srfi-42.html")
    11    (exports "srfi-42-support.exports")
    12    (require-at-runtime srfi-42-support)))
     15   ))
  • release/4/srfi-42/trunk/tests/run.scm

    r10032 r14549  
    1 ;;;; srfi-42-examples.scm - Egner's examples for SRFI-42, slightly massaged by felix
    2 
    3 (use syntax-case srfi-42)
    4 
    5 ; Compile like this: csc examples.scm -H -R srfi-42
    6 
    7 ; <PLAINTEXT>
     1(use srfi-42)
     2
    83; Examples for Eager Comprehensions in [outer..inner|expr]-Convention
    94; ===================================================================
    105;
    11 ; sebastian.egner@philips.com, Eindhoven, The Netherlands, Feb-2003.
     6; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007.
    127; Scheme R5RS (incl. macros), SRFI-23 (error).
     8;
     9; Ported to Chicken Scheme by Ivan Raikov.
    1310;
    14 ; Running the examples in Scheme48 (version 0.57):
    15 ;   ,open srfi-23
    16 ;   ,load ec.scm
    17 ;   (define my-open-output-file open-output-file)
    18 ;   (define my-call-with-input-file call-with-input-file)
    19 ;   ,load examples.scm
    20 ;
    21 ; Running the examples in PLT/DrScheme (version 202):
    22 ;   ; open "ec.scm", click Execute
    23 ;   (define (my-open-output-file filename)
    24 ;     (open-output-file filename 'replace 'text) )
    25 ;   (define (my-call-with-input-file filename thunk)
    26 ;     (call-with-input-file filename thunk 'text) )
    27 ;   (load "examples.scm")
    28 ;
    29 ; Running the examples in SCM (version 5d7):
    30 ;   (require 'macro) (require 'record)
    31 ;   (load "ec.scm")
    32 ;   (define my-open-output-file open-output-file)
    33 ;   (define my-call-with-input-file call-with-input-file)
    34 ;   (load "examples.scm")
     11
    3512
    3613(define my-open-output-file open-output-file)
     
    7350(define-syntax my-check
    7451  (syntax-rules (=>)
    75     ((my-check ec => desired-result) (do-check 'ec (lambda () ec) desired-result)) ) )
    76 
    77 (define (do-check ec thunk desired-result)
    78   (newline)
    79   (write ec)
    80   (newline)
    81   (let ((actual-result (thunk)))
    82     (display "  => ")
    83     (write actual-result)
    84     (if (my-equal? actual-result desired-result)
    85         (begin
    86           (display " ; correct")
    87           (set! my-check-correct (+ my-check-correct 1)) )
    88         (begin
    89           (display " ; *** wrong ***, desired result:")
    90           (newline)
    91           (display "  => ")
    92           (write desired-result)
    93           (set! my-check-wrong (+ my-check-wrong 1)) ))
    94     (newline) ))
     52    ((my-check ec => desired-result)
     53     (begin
     54       (newline)
     55       (write (quote ec))
     56       (newline)
     57       (let ((actual-result ec))
     58         (display "  => ")
     59         (write actual-result)
     60         (if (my-equal? actual-result desired-result)
     61             (begin
     62               (display " ; correct")
     63               (set! my-check-correct (+ my-check-correct 1)) )
     64             (begin
     65               (display " ; *** wrong ***, desired result:")
     66               (newline)
     67               (display "  => ")
     68               (write desired-result)
     69               (set! my-check-wrong (+ my-check-wrong 1)) ))
     70         (newline) )))))
    9571             
    9672
     
    347323 => '(1 2 3 4 5) )
    348324
     325; with generator that might use inner bindings
     326
     327(my-check
     328 (list-ec (:while (:list i '(1 2 3 4 5 6 7 8 9)) (< i 5)) i)
     329 => '(1 2 3 4) )
     330; Was broken in original reference implementation as pointed
     331; out by sunnan@handgranat.org on 24-Apr-2005 comp.lang.scheme.
     332; Refer to http://groups-beta.google.com/group/comp.lang.scheme/
     333; browse_thread/thread/f5333220eaeeed66/75926634cf31c038#75926634cf31c038
     334
     335(my-check
     336 (list-ec (:until (:list i '(1 2 3 4 5 6 7 8 9)) (>= i 5)) i)
     337 => '(1 2 3 4 5) )
     338
     339(my-check
     340 (list-ec (:while (:vector x (index i) '#(1 2 3 4 5))
     341                  (< x 10))
     342          x)
     343 => '(1 2 3 4 5))
     344; Was broken in reference implementation, even after fix for the
     345; bug reported by Sunnan, as reported by Jens-Axel Soegaard on
     346; 4-Jun-2007.
     347
     348; combine :while/:until and :parallel
     349
     350(my-check
     351 (list-ec (:while (:parallel (:range i 1 10)
     352                             (:list j '(1 2 3 4 5 6 7 8 9)))
     353                  (< i 5))
     354          (list i j))
     355 => '((1 1) (2 2) (3 3) (4 4)))
     356
     357(my-check
     358 (list-ec (:until (:parallel (:range i 1 10)
     359                             (:list j '(1 2 3 4 5 6 7 8 9)))
     360                  (>= i 5))
     361          (list i j))
     362 => '((1 1) (2 2) (3 3) (4 4) (5 5)))
     363
     364; check that :while/:until really stop the generator
     365
     366(my-check
     367 (let ((n 0))
     368   (do-ec (:while (:range i 1 10) (begin (set! n (+ n 1)) (< i 5)))
     369          (if #f #f))
     370   n)
     371 => 5)
     372
     373(my-check
     374 (let ((n 0))
     375   (do-ec (:until (:range i 1 10) (begin (set! n (+ n 1)) (>= i 5)))
     376          (if #f #f))
     377   n)
     378 => 5)
     379
     380(my-check
     381 (let ((n 0))
     382   (do-ec (:while (:parallel (:range i 1 10)
     383                             (:do () (begin (set! n (+ n 1)) #t) ()))
     384                  (< i 5))
     385          (if #f #f))
     386   n)
     387 => 5)
     388
     389(my-check
     390 (let ((n 0))
     391   (do-ec (:until (:parallel (:range i 1 10)
     392                             (:do () (begin (set! n (+ n 1)) #t) ()))
     393                  (>= i 5))
     394          (if #f #f))
     395   n)
     396 => 5)
    349397
    350398; ==========================================================================
Note: See TracChangeset for help on using the changeset viewer.