Changeset 39705 in project


Ignore:
Timestamp:
03/14/21 19:19:30 (2 months ago)
Author:
Kon Lovett
Message:

better(?) "hidden" export names, new test runner, canon author style

Location:
release/5/srfi-41/trunk
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/srfi-41/trunk/srfi-41.egg

    r38727 r39705  
    11;;;; srfi-41.egg  -*- scheme -*-
    2 ;;;; Kon Lovett, Apr '20
    3 ;;;; Kon Lovett, Feb '19
    42
    53((synopsis "SRFI 41 (Streams)")
    6  ;(date "2009-04-02")
    74 (version "2.0.3")
    85 (category data)
    9  (author "Philip L. Bewig, for CHICKEN by [[kon lovett]]")
     6 (author "Philip L. Bewig, for CHICKEN by Kon Lovett")
     7 (maintainer "Kon Lovett")
    108 (license "BSD")
    11  (dependencies
    12         (check-errors "3.1.0")
    13         (record-variants "1.0"))
     9 (dependencies check-errors record-variants)
    1410 (test-dependencies check-errors)
    1511 (components
    16   (extension streams-primitive
    17     (types-file)
    18     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    19   (extension streams-derived
    20     (types-file)
    21     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    2212  (extension streams
    2313    (types-file)
     
    2818    (component-dependencies streams-primitive streams-derived)
    2919    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     20  (extension streams-primitive
     21    (types-file)
     22    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
     23  (extension streams-derived
     24    (types-file)
     25    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks"))
    3026  (extension streams-utils
    3127    (types-file)
  • release/5/srfi-41/trunk/streams-derived.scm

    r38514 r39705  
    5252  stream-range
    5353  stream-zip
    54   ;so can reexport
     54  ;explicit export: compiler cannot follow syntax >-> syntax
    5555  stream-match-test
    5656  stream-match-pattern)
    5757
    58 (import scheme)
    59 (import (chicken base))
    60 ;(import (srfi 9))
    61 ;(import (srfi 23))
    62 (import streams-primitive)
    63 (import (only type-errors
    64   error-number error-procedure
    65   error-natural-integer
    66   error-input-port error-list))
     58(import scheme
     59  (chicken base)
     60  (srfi 9)
     61  (srfi 23)
     62  streams-primitive
     63  (only type-errors
     64    error-number error-procedure
     65    error-natural-integer
     66    error-input-port error-list))
    6767
    6868(include "chicken-primitive-object-inlines")
  • release/5/srfi-41/trunk/streams-primitive.scm

    r38514 r39705  
    1919
    2020(;export
    21   ; srfi-41 primitive
     21  ;srfi-41 primitive
    2222  stream?
    2323  stream-null
    2424  stream-null?
    25   (stream-cons $$make-stream-pair)
     25  (stream-cons $make-stream-pair$)
    2626  stream-pair?
    2727  stream-car
    2828  stream-cdr
    2929  stream-lambda
    30   ;;Extras
     30  ;extras
    3131  stream-occupied?
    32   ;extras
    3332  check-stream
    3433  error-stream
    3534  check-stream-occupied
    3635  error-stream-occupied
    37   ;so can reexport
    38   $$stream-lazy
    39   $$stream-eager
    40   $$stream-delay
    41   $$make-stream-lazy
    42   $$make-stream-eager
    43   $$make-stream-pair)
     36  ;explicit export: compiler cannot follow syntax >-> syntax
     37  $stream-lazy$
     38  $stream-eager$
     39  $stream-delay$
     40  $make-stream-lazy$
     41  $make-stream-eager$
     42  $make-stream-pair$)
    4443
    45 (import scheme)
    46 (import (chicken base))
    47 (import type-checks)
    48 (import type-errors)
    49 (import record-variants)
     44(import scheme
     45  (chicken base)
     46  type-checks
     47  type-errors
     48  record-variants)
    5049
    5150(include "chicken-primitive-object-inlines")
     
    5655;; ensure identifier defined
    5756(define stream 'stream)
    58 
    5957(define-record-type-variant stream (unsafe unchecked inline)
    6058  (%make-stream prom)
    61   $stream?  ;ignore since %stream? conflicts with predefined inline
     59  ($stream?)  ;ignore since %stream? conflicts with predefined inline
    6260  (prom %stream-promise %stream-promise-set!) )
    6361
     
    7573(define-inline (stream-box-tag-set! box tag) (%set-car!/immediate box tag))
    7674(define-inline (stream-box-value-set! box val) (%set-cdr! box val))
     75
    7776(define-inline (make-stream-lazy-box obj) (make-stream-box 'lazy obj))
    7877(define-inline (make-stream-eager-box obj) (make-stream-box 'eager obj))
     78
    7979(define-inline (check-stream-box loc obj)
    8080  (unless (stream-tagged-pair? obj)
     
    8484;;;
    8585
    86 (define ($$make-stream-lazy thunk) (%make-stream (make-stream-lazy-box thunk)))
    87 (define ($$make-stream-eager obj) (%make-stream (make-stream-eager-box obj)))
     86(define ($make-stream-lazy$ thunk) (%make-stream (make-stream-lazy-box thunk)))
     87(define ($make-stream-eager$ obj) (%make-stream (make-stream-eager-box obj)))
    8888
    89 (define-syntax $$stream-lazy
     89(define-syntax $stream-lazy$
    9090  (syntax-rules ()
    91     (($$stream-lazy ?expr)
    92       ($$make-stream-lazy (lambda () ?expr)) ) ) )
     91    (($stream-lazy$ ?expr)
     92      ($make-stream-lazy$ (lambda () ?expr)) ) ) )
    9393
    94 (define-syntax $$stream-eager
     94(define-syntax $stream-eager$
    9595  (syntax-rules ()
    96     (($$stream-eager ?expr)
    97       ($$make-stream-eager ?expr) ) ) )
     96    (($stream-eager$ ?expr)
     97      ($make-stream-eager$ ?expr) ) ) )
    9898
    99 (define-syntax $$stream-delay
     99(define-syntax $stream-delay$
    100100  (syntax-rules ()
    101     (($$stream-delay ?expr)
    102       ($$stream-lazy ($$stream-eager ?expr)) ) ) )
     101    (($stream-delay$ ?expr)
     102      ($stream-lazy$ ($stream-eager$ ?expr)) ) ) )
    103103
    104104(define (stream-force prom)
     
    119119          ;better be there! (check-stream-box #f content)
    120120          (unless (eq? 'eager (stream-box-tag content))
    121             (let (
    122               (content* (%stream-promise prom*)) )
     121            (let ((content* (%stream-promise prom*)))
    123122              (stream-box-tag-set! content (stream-box-tag content*))
    124123              (stream-box-value-set! content (stream-box-value content*)) )
     
    130129(define (stream? obj) (%stream? obj))
    131130
    132 (define stream-null ($$stream-delay (%cons 'stream 'null)))
     131(define stream-null ($stream-delay$ (%cons 'stream 'null)))
    133132
    134133(define-inline (*stream-null? strm)
     
    143142  (syntax-rules ()
    144143    ((stream-lambda ?formals ?body0 ?body1 ...)
    145      (lambda ?formals ($$stream-lazy (let () ?body0 ?body1 ...))) ) ) )
     144     (lambda ?formals ($stream-lazy$ (let () ?body0 ?body1 ...))) ) ) )
    146145
    147146;;
     
    149148;; ensure identifier defined
    150149(define stream-pair 'stream-pair)
    151 
    152150(define-record-type-variant stream-pair (unsafe unchecked inline)
    153   (%make-stream-pair car cdr)
    154   %stream-pair?
    155   (car %stream-car)
    156   (cdr %stream-cdr) )
     151  (%make-stream-pair hd tl)
     152  (%stream-pair?)
     153  (hd %stream-car)
     154  (tl %stream-cdr) )
    157155
    158156;want inline car/cdr but need exportable procedure for make.
    159 (define ($$make-stream-pair car cdr)
    160   (%make-stream-pair car cdr) )
     157(define ($make-stream-pair$ hd tl) (%make-stream-pair hd tl))
    161158
    162159(define-error-type stream-pair)
     
    177174  (syntax-rules ()
    178175    ((_ ?expr ?strm)
    179       ($$stream-eager ($$make-stream-pair ($$stream-delay ?expr) ($$stream-lazy ?strm))) ) ) )
     176      ($stream-eager$ ($make-stream-pair$ ($stream-delay$ ?expr) ($stream-lazy$ ?strm))) ) ) )
    180177
    181178(define (stream-pair? obj)
  • release/5/srfi-41/trunk/tests/run.scm

    r38514 r39705  
    33(import scheme)
    44
    5 ;;; Create Egg Const
     5;; Create Egg Const
    66
    7 (define EGG-NAME "srfi-41")
     7(include-relative "run-ident")
    88
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
     
    1818
    1919(define *args* (argv))
     20(define *current-directory* (cond-expand (unix "./") (else #f)))
     21;no -disable-interrupts or -no-lambda-info
     22(define *csc-init-options* '(-inline-global -local -inline -specialize
     23  -optimize-leaf-routines -clustering -lfa2 -no-trace -unsafe -strict-types))
     24(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
    2025
    21 (define (egg-name args #!optional (def EGG-NAME))
     26(define (remq obj ls)
     27  (let loop ((curr ls) (prev '()))
     28    (cond
     29      ((null? curr)
     30        ls )
     31      ((eq? obj (car curr))
     32        (if (null? prev)
     33          (cdr ls)
     34          (begin
     35            (set-cdr! prev (cdr curr))
     36            ls ) ) )
     37      (else
     38        (loop (cdr curr) curr) ) ) ) )
     39
     40(define (remqs os ls)
     41  (let loop ((ls ls) (os os))
     42    (cond
     43      ((null? os)
     44        ls )
     45      (else
     46        (loop (remq (car os) ls) (cdr os)) ) ) ) )
     47
     48(define (egg-name #!optional (args *args*) (def EGG-NAME))
    2249  (cond
    2350    ((<= 4 (length *args*)) (cadddr *args*) )
     
    2653      (error 'run "cannot determine egg-name") ) ) )
    2754
    28 (define *current-directory* (cond-expand (unix "./") (else #f)))
    29 (define *egg* (egg-name *args*))
     55(define (as-csc-options ls)
     56  (apply string-append (intersperse (map symbol->string ls) " ")) )
    3057
    31 ;no -disable-interrupts or -no-lambda-info
    32 (define *csc-options* "-inline-global -local -inline \
    33   -specialize -optimize-leaf-routines -clustering -lfa2 \
    34   -no-trace -unsafe \
    35   -strict-types")
     58(define (csc-options)
     59  (as-csc-options (remqs *csc-remv-options* *csc-init-options*)) )
    3660
    37 (define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
    3861(define (test-filename name) (string-append name "-test"))
     62
    3963(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
    4064
     
    4367    name
    4468    (make-pathname *current-directory* (test-filename name) "scm") ) )
     69
     70;;
    4571
    4672(define (run-test-evaluated source)
     
    5480  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
    5581
    56 ;;;
    57 
    58 (define (run-test #!optional (name *egg*) (csc-options *csc-options*))
     82(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
    5983  (let (
    6084    (source (ensure-test-source-name name)) )
     
    6589    (run-test-compiled source csc-options) ) )
    6690
    67 (define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     91(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
    6892  (for-each (cut run-test <> csc-options) tests) )
    6993
    70 ;;; Do Test
     94;; Do Test
    7195
    7296(run-tests)
Note: See TracChangeset for help on using the changeset viewer.