Changeset 39452 in project


Ignore:
Timestamp:
12/22/20 14:43:10 (4 weeks ago)
Author:
Alaric Snell-Pym
Message:

Port combinators to C5

Location:
release/5/combinators/trunk
Files:
1 added
10 edited

Legend:

Unmodified
Added
Removed
  • release/5/combinators/trunk/bi-combinators.scm

    r34400 r39452  
    44(module bi-combinators
    55
    6 (;export
    7   bi bi2 bi3 bi-each bi-all)
     6  (;export
     7    bi bi2 bi3 bi-each bi-all)
    88
    9 (import
    10   scheme
    11   chicken)
     9  (import
     10    scheme)
    1211
     12  (cond-expand
     13   (chicken-4
     14    (import chicken))
     15   (chicken-5
     16    (import (chicken base))))
    1317#|
    1418;;; Hook
  • release/5/combinators/trunk/combinators.meta

    r34400 r39452  
    99 (depends (setup-helper "1.5.2"))
    1010 (test-depends test)
    11  (files
    12    "arguments-helpers.inc.scm"
    13    "logical-combinators.scm"
    14    "section-combinators.scm"
    15    "sort-combinators.scm"
    16    "generic-section-combinators.scm"
    17    "stack-combinators.scm"
    18    "uni-combinators.scm" "bi-combinators.scm" "tri-combinators.scm"
    19    "combinators.meta" "combinators.setup" "combinators.release-info"
    20    "tests/run.scm") )
     11 (files "logical-combinators.scm" "section-combinators.scm" "combinators.meta" "combinators.release-info" "uni-combinators.scm" "generic-section-combinators.scm" "combinators.setup" "arguments-helpers.inc" "stack-combinators.scm" "tri-combinators.scm" "bi-combinators.scm" "sort-combinators.scm" "tests/run.scm") )
  • release/5/combinators/trunk/generic-section-combinators.scm

    r34400 r39452  
    22;;;; Kon Lovett, Jul '10
    33
    4 ;; Issues
    5 ;;
    6 ;; !IN PROGRESS!
     4!IN PROGRESS!
    75
    86(module generic-section-combinators
    97
    10 (;export
    11   left-hook-each right-hook-each
    12   left-hook-each+ right-hook-each+
    13   left-hook-argument-chain right-hook-argument-chain
    14   left-hook-argument-chain+ right-hook-argument-chain+
    15   fork-each fork-all
    16   fork-each+ fork-all+)
     8  (;export
     9    left-hook-each right-hook-each
     10    left-hook-each+ right-hook-each+
     11    left-hook-argument-chain right-hook-argument-chain
     12    left-hook-argument-chain+ right-hook-argument-chain+
     13    fork-each fork-all
     14    fork-each+ fork-all+)
    1715
    18 (import
    19   (except scheme map)
    20   chicken
    21   (only data-structures identity)
    22   (only srfi-1 circular-list map))
     16  (import (except scheme map))
    2317
    24 (require-library data-structures srfi-1)
     18  (cond-expand
     19   (chicken-4
     20    (require-library data-structures srfi-1)
     21    (import
    2522
    26 (declare
    27   (type
    28     (left-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    29     (right-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    30     (left-hook-each+ (procedure (#!rest) (procedure (#!rest) *)))
    31     (right-hook-each+ (procedure (#!rest) (procedure (#!rest) *)))
    32     (left-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    33     (right-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    34     (left-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *)))
    35     (right-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *)))
    36     (fork-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    37     (fork-all (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    38     (fork-each+ (procedure (#!rest) (procedure (#!rest) *)))
    39     (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) ))
     23     chicken
     24     (only data-structures identity)
     25     (only srfi-1 circular-list map)))
     26   (chicken-5
     27    (import (chicken base))
     28    (import
     29     (only srfi-1 circular-list map))))
    4030
    41 (include "arguments-helpers.inc")
     31  (declare
     32    (type
     33      (left-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     34      (right-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     35      (left-hook-each+ (procedure (#!rest) (procedure (#!rest) *)))
     36      (right-hook-each+ (procedure (#!rest) (procedure (#!rest) *)))
     37      (left-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     38      (right-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     39      (left-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *)))
     40      (right-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *)))
     41      (fork-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     42      (fork-all (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     43      (fork-each+ (procedure (#!rest) (procedure (#!rest) *)))
     44      (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) ))
     45
     46  (include "arguments-helpers.inc")
    4247
    4348;;; Hook
     
    4954  (lambda xs ((X-funcs (cons list fns)) xs)) )
    5055
    51 #|
    5256?????
    5357(left-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X fn0 ... fnn list))
    5458(right-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X list fn0 ... fnn))
    55 |#
    5659
    5760;; left-hook-each
     
    6265
    6366(define (left-hook-each c . fns)
    64   (if (null? fns)
    65     (lambda xs (apply c xs))
     67  (if (null? fns) (lambda xs (apply c xs))
    6668    (let ((fn (each-func fns)))
    6769      (lambda xs (apply c (append (list (fn xs)) xs))) ) ) )
     
    7476
    7577(define (right-hook-each c . fns)
    76   (if (null? fns)
    77     (lambda xs (apply c xs))
     78  (if (null? fns) (lambda xs (apply c xs))
    7879    (let ((fn (each-func fns)))
    7980      (lambda xs (apply c (append xs (list (fn xs))))) ) ) )
     
    8687
    8788(define (left-hook-each+ . fns)
    88   (if (null? fns)
    89     (lambda (c) (left-hook-each+ c))
     89  (if (null? fns) (lambda (c) (left-hook-each+ c))
    9090    (let ((c (car fns)) (fns (cdr fns)))
    91       (if (null? fns)
    92         (lambda fns (apply left-hook-each+ c fns))
     91      (if (null? fns) (lambda fns (apply left-hook-each+ c fns))
    9392        (apply left-hook-each c fns) ) ) ) )
    9493
     
    10099
    101100(define (right-hook-each+ . fns)
    102  (if (null? fns) (lambda (c)
    103     (right-hook-each+ c))
     101 (if (null? fns) (lambda (c) (right-hook-each+ c))
    104102    (let ((c (car fns)) (fns (cdr fns)))
    105       (if (null? fns)
    106         (lambda fns (apply right-hook-each+ c fns))
     103      (if (null? fns) (lambda fns (apply right-hook-each+ c fns))
    107104        (apply right-hook-each c fns) ) ) ) )
    108105
     
    116113  (let ((c (car fns))
    117114        (fns (cdr fns)) )
    118     (if (null? fns)
    119       (lambda xs (apply c xs))
     115    (if (null? fns) (lambda xs (apply c xs))
    120116      (lambda xs (apply c (chain-recur fns xs) xs)) ) ) )
    121117
     
    129125  (let ((c (car fns))
    130126        (fns (cdr fns)) )
    131     (if (null? fns)
    132       (lambda xs (apply c xs))
     127    (if (null? fns) (lambda xs (apply c xs))
    133128      (lambda xs (apply c (append xs (list (chain-recur fns xs))))) ) ) )
    134129
     
    140135
    141136(define (left-hook-argument-chain+ . fns)
    142   (if (null? fns)
    143     (lambda (c) (left-hook-argument-chain+ c))
     137  (if (null? fns) (lambda (c) (left-hook-argument-chain+ c))
    144138    (let ((c (car fns)) (fns (cdr fns)))
    145       (if (null? fns)
    146         (lambda fns (apply left-hook-argument-chain+ c fns))
     139      (if (null? fns) (lambda fns (apply left-hook-argument-chain+ c fns))
    147140        (apply left-hook-argument-chain c fns) ) ) ) )
    148141
     
    154147
    155148(define (right-hook-argument-chain+ . fns)
    156  (if (null? fns)
    157     (lambda (c) (right-hook-argument-chain+ c))
     149 (if (null? fns) (lambda (c) (right-hook-argument-chain+ c))
    158150    (let ((c (car fns)) (fns (cdr fns)))
    159       (if (null? fns)
    160         (lambda fns (apply right-hook-argument-chain+ c fns))
     151      (if (null? fns) (lambda fns (apply right-hook-argument-chain+ c fns))
    161152        (apply right-hook-argument-chain c fns) ) ) ) )
    162153
     
    186177
    187178(define (fork-each+ . fns)
    188   (if (null? fns)
    189     (lambda (c) (fork-each+ c))
     179  (if (null? fns) (lambda (c) (fork-each+ c))
    190180    (let ((c (car fns)) (fns (cdr fns)))
    191       (if (null? fns)
    192         (lambda fns (apply fork-each+ c fns))
     181      (if (null? fns) (lambda fns (apply fork-each+ c fns))
    193182        (apply fork-each c fns) ) ) ) )
    194183
     
    200189
    201190(define (fork-all+ . fns)
    202   (if (null? fns)
    203     (lambda (c) (fork-all+ c))
     191  (if (null? fns) (lambda (c) (fork-all+ c))
    204192    (let ((c (car fns)) (fns (cdr fns)))
    205       (if (null? fns)
    206         (lambda fns (apply fork-all+ c fns))
     193      (if (null? fns) (lambda fns (apply fork-all+ c fns))
    207194        (apply fork-all c fns) ) ) ) )
    208195
  • release/5/combinators/trunk/logical-combinators.scm

    r34400 r39452  
    44(module logical-combinators
    55
    6 (;export
    7   andf
    8   orf)
     6  (;export
     7    andf
     8    orf)
    99
    10 (import scheme chicken data-structures srfi-1)
     10  (import scheme)
    1111
    12 (declare
    13   (type
    14     (andf (procedure (#!rest) *))
    15     (orf (procedure (#!rest) *)) ) )
     12  (cond-expand
     13   (chicken-4
     14    (import chicken data-structures srfi-1))
     15   (chicken-5
     16    (import (chicken base))
     17    (import srfi-1)))
     18
     19  (declare
     20    (type
     21      (andf (procedure (#!rest) *))
     22      (orf (procedure (#!rest) *)) ) )
    1623
    1724;; Eager 'or' & 'and'
     
    1926(define (andf . args)
    2027  (let loop ((args args) (prev #t))
    21     (if (null? args)
    22       prev
    23       (let ((cur (car args)))
    24         (and cur (loop (cdr args) cur) ) ) ) ) )
     28    (if (null? args) prev
     29        (let ((cur (car args)))
     30          (and cur
     31              (loop (cdr args) cur) ) ) ) ) )
    2532
    2633(define (orf . args)
    2734  (let loop ((args args))
    28     (and
    29       (not (null? args))
    30       (or (car args) (loop (cdr args)) ) ) ) )
     35    (and (not (null? args))
     36         (or (car args)
     37            (loop (cdr args)) ) ) ) )
    3138
    3239) ;module logical-combinators
  • release/5/combinators/trunk/section-combinators.scm

    r34400 r39452  
    44(module section-combinators
    55
    6 (;export
    7   left-section right-section
    8   crop-left crop-right
    9   reversed
    10   arguments-chain arguments-each arguments-all)
     6  (;export
     7    left-section right-section
     8    crop-left crop-right
     9    reversed
     10    arguments-chain arguments-each arguments-all)
    1111
    12 (import
    13   scheme
    14   chicken
    15   (only (srfi 1) drop drop-right circular-list)
    16   (only data-structures identity))
    17 (require-library data-structures (srfi 1))
     12  (import
     13    scheme)
    1814
    19 (declare
    20   (type
    21     (left-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    22     (right-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
    23     (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *)))
    24     (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
    25     (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
    26     (arguments-chain (procedure (#!rest) (procedure (#!rest) *)))
    27     (arguments-each (procedure (#!rest) (procedure (#!rest) list)))
    28     (arguments-all (procedure (#!rest) (procedure (#!rest) list))) ) )
     15  (cond-expand
     16   (chicken-4
     17    (import chicken)
     18    (import (only srfi-1 drop drop-right circular-list))
     19    (import (only data-structures identity))
     20    (require-library srfi-1))
     21   (chicken-5
     22    (import (chicken base))
     23    (import (only srfi-1 drop drop-right circular-list))
     24    (import (only (chicken base) identity))))
     25
     26
     27  (declare
     28    (type
     29      (left-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     30      (right-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
     31      (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *)))
     32      (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
     33      (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
     34      (arguments-chain (procedure (#!rest) (procedure (#!rest) *)))
     35      (arguments-each (procedure (#!rest) (procedure (#!rest) list)))
     36      (arguments-all (procedure (#!rest) (procedure (#!rest) list))) ) )
    2937
    3038;;; Section
     
    5563;;; Argument
    5664
    57 (include "arguments-helpers.inc")
     65  (include "arguments-helpers.inc")
    5866
    5967;; arguments-chain
  • release/5/combinators/trunk/sort-combinators.scm

    r34400 r39452  
    66;; - group/key is not a combinator
    77
    8 (module sort-combinators
    9 
    10 (;export
     8(module sort-combinators (;export
    119  group-by group/key
    1210  make-equal/key make-less-than/key)
    1311
    14 (import
    15   scheme
    16   chicken
    17   (only (srfi 1) span)
    18   (only bi-combinators bi-each))
    19 (require-library (srfi 1) bi-combinators)
     12  (import scheme)
    2013
    21 (declare
    22   (type
    23     (group-by (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (list) list)))
    24     (group/key (procedure ((procedure (*) *) list #!optional (procedure (* *) boolean)) list))
    25     (make-less-than/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean)))
    26     (make-equal/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) ) )
     14  (cond-expand
     15   (chicken-4
     16    (import chicken)
     17    (import (only srfi-1 span))
     18    (import (only bi-combinators bi-each))
     19    (require-library srfi-1 bi-combinators))
     20   (chicken-5
     21    (import (chicken base))
     22    (import (only srfi-1 span))
     23    (import (only bi-combinators bi-each))))
     24
     25  (declare
     26    (type
     27      (group-by (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (list) list)))
     28      (group/key (procedure ((procedure (*) *) list #!optional (procedure (* *) boolean)) list))
     29      (make-less-than/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean)))
     30      (make-equal/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) ) )
    2731
    2832;;
    2933
    30 ;kinda violates the argument list orientation of combinators
     34;kinda violates the argument list orientation of comibinators
    3135(define (group-by proc #!optional (equals equal?))
    3236  (lambda (ls)
    3337    (let loop ((ls ls) (acc '()))
    34       (if (null? ls)
    35         acc #;(reverse! acc)
    36         (let ((key (proc (car ls))))
    37           (receive (grouped rest) (span (lambda (item) (equals key (proc item))) ls)
    38             (loop rest (cons grouped acc)) ) ) ) ) ) )
     38      (if (null? ls) acc #;(reverse! acc)
     39          (let ((key (proc (car ls))))
     40            (receive (grouped rest) (span (lambda (item) (equals key (proc item))) ls)
     41              (loop rest (cons grouped acc)) ) ) ) ) ) )
    3942
    4043;; Group a list of elements by some key attribute.
  • release/5/combinators/trunk/stack-combinators.scm

    r34400 r39452  
    77(module stack-combinators
    88
    9 (;export
    10   uni uni2 uni3 uni@
    11   bi bi2 bi3 bi@
    12   tri tri2 tri3 tri@
    13   dip
    14   dup dupd
    15   swap
    16   drop drop/2)
     9  (;export
     10    uni uni2 uni3 uni@
     11    bi bi2 bi3 bi@
     12    tri tri2 tri3 tri@
     13    dip
     14    dup dupd
     15    swap
     16    drop drop/2)
     17 
     18  (import scheme)
    1719
    18 (import scheme chicken)
    19 
     20  (cond-expand
     21   (chicken-4
     22    (import chicken))
     23   (chicken-5
     24    (import (chicken base))))
    2025;;
    2126
  • release/5/combinators/trunk/tests/run.scm

    r21916 r39452  
    1 (use test)
    2 (use section-combinators)
     1(cond-expand
     2 (chicken-4
     3  (use test)
     4  (use section-combinators))
     5 (chicken-5
     6  (import test)
     7  (import section-combinators)))
    38
    49(test "arguments-chain" '6 ((arguments-chain + list) 1 2 3))
     
    813(test "arguments-all" '(6 -4 6) ((arguments-all + - *) 1 2 3))
    914
    10 (use sort-combinators)
     15(cond-expand
     16 (chicken-4
     17  (use sort-combinators))
     18 (chicken-5
     19  (import sort-combinators)))
    1120
    1221(test "make-less-than/key" '#t ((make-less-than/key car) '(2) '(3)))
  • release/5/combinators/trunk/tri-combinators.scm

    r34400 r39452  
    44(module tri-combinators
    55
    6 (;export
    7   tri tri2 tri3 tri-each tri-all)
     6  (;export
     7    tri tri2 tri3 tri-each tri-all)
    88
    9 (import
    10   scheme
    11   chicken)
    12 
     9  (import
     10   scheme)
     11 
     12  (cond-expand
     13   (chicken-4
     14    (import chicken))
     15   (chicken-5
     16    (import (chicken base))))
    1317;;; Hook
    1418
  • release/5/combinators/trunk/uni-combinators.scm

    r34400 r39452  
    44(module uni-combinators
    55
    6 (;export
    7   uni uni2 uni3 uni-each uni-all)
     6  (;export
     7    uni uni2 uni3 uni-each uni-all)
    88
    9 (import
    10   scheme
    11   chicken)
     9  (import scheme)
     10
     11  (cond-expand
     12   (chicken-4
     13    (import chicken))
     14   (chicken-5
     15    (import (chicken base))))
    1216
    1317#|
Note: See TracChangeset for help on using the changeset viewer.