Changeset 35201 in project


Ignore:
Timestamp:
02/25/18 05:34:22 (10 months ago)
Author:
kon
Message:

add delete-keyword-arguments , bump ver , re-flow , add define:-record-type tag define-type , add types

Location:
release/4/dsssl-utils/trunk
Files:
1 added
6 edited

Legend:

Unmodified
Added
Removed
  • release/4/dsssl-utils/trunk/dsssl-utils.meta

    r34787 r35201  
    77 (doc-from-wiki)
    88 (synopsis "dsssl-utils")
    9  (depends (setup-helper "1.5.2"))
     9 (depends
     10  (setup-helper "1.5.2")
     11  (symbol-utils "1.0.3"))
    1012 (test-depends test)
    1113 (files
     
    1416  "lambda+.scm"
    1517  "typed-define.scm"
    16   "tests/run.scm") )
     18  "tests/run.scm" "dsssl-utils-test.scm") )
  • release/4/dsssl-utils/trunk/dsssl-utils.scm

    r34787 r35201  
    11;;;; dsssl-utils.scm
    22;;;; Kon Lovett, Aug '10
     3;;;; Kon Lovett, Feb '18
    34
    45(module dsssl-utils
     
    78  dsssl-fixup
    89  fixup-dsssl-lambda-list
    9   scrub-dsssl-keys)
     10  delete-keyword-arguments
     11  ;deprecated
     12  scrub-dsssl-keys )
    1013
    11 (import scheme)
    12 
    13 (import chicken)
    14 
    15 (import (only srfi-1 append! reverse!))
    16 (require-library srfi-1)
    17 
    18 ;;
    19 
    20 #| ;These "push" visibly into the background
    21 (define-syntax λ
    22   (syntax-rules ()
    23     ((_ ?arg0 ...) (lambda+ ?arg0 ...))))
    24 
    25 (define-syntax ^
    26   (syntax-rules ()
    27     ((_ ?arg0 ...) (lambda+ ?arg0 ...))))
    28 |#
     14(import scheme chicken)
     15(use
     16  (only srfi-1 append! reverse!)
     17  (only symbol-utils symbol->keyword))
    2918
    3019;; DSSSL Extended Lambda List fixup
     
    3221;; Compensates for the #!rest #!key order; should be #!key #!rest.
    3322
     23;(: dsssl-fixup (list list list --> list))
     24;
    3425(define-syntax dsssl-fixup
    3526  (syntax-rules ()
     
    5445            (list (cons ?key0 ?keyvar0) ...)
    5546            ?rest) ) )
    56         ;
    57         (let-values (((?optvar0 ...) (apply values opts)))
    58           (let-values (((?keyvar0 ...) (apply values keys)))
    59             ?body ...) ) ) )
     47        (let-values (
     48          ((?optvar0 ...) (apply values opts))
     49          ((?keyvar0 ...) (apply values keys)) )
     50          ?body ... ) ) )
     51    ;
     52    ((_ ((?key0 ?keyvar0) ...) ?rest ?body ...)
     53      (dsssl-fixup () (((?key0 ?keyvar0) ...) ?rest ?body ...)) )
    6054    ;
    6155    ((_ ?opt ((?key0 ?keyvar0) ...) ?rest ?body ...)
     
    6660;This is ridiculous. Better to just supply own define & lambda.
    6761
     62(: fixup-dsssl-lambda-list (list list list --> list list list))
     63;
    6864(define (fixup-dsssl-lambda-list opts keys rest)
    6965  ;
     
    7268      (if (null? opts)
    7369        (append! (reverse! pref) rest)
    74         (let ((opt (car opts))
    75               (nxtopts (cdr opts)) )
     70        (let (
     71          (opt (car opts))
     72          (nxtopts (cdr opts)) )
    7673          (let ((val (car opt)) )
    7774            (cond
     
    9996            (loop '() '() (default-optionals opts optionals) rest) ) ) )
    10097      (else
    101         (let ((arg (car args))
    102               (nxt (cdr args)) )
     98        (let (
     99          (arg (car args))
     100          (nxt (cdr args)) )
    103101          (let ((key? (assq arg keys)))
    104102            (cond
     
    115113              ; opt given a key by mistake
    116114              ((assq (caar opts) keys)
    117                 (let ((optionals (cons arg optionals))
    118                       (nxtopts (cdr opts)) )
     115                (let (
     116                  (optionals (cons arg optionals))
     117                  (nxtopts (cdr opts)) )
    119118                  (cond
    120119                    ; just this opt
     
    132131;; Returns the argument list w/o key+val pairs
    133132
    134 ; keys = (keyed...)
    135 (define (scrub-dsssl-keys keys rest)
    136   (let loop ((args rest) (rest '()))
    137     (if (null? args)
    138       (reverse! rest)
    139       (let ((arg (car args))
    140             (nxt (cdr args)) )
    141         (if (memq arg keys)
    142           (if (not (null? nxt))
    143             (loop (cdr nxt) rest)
    144             (error 'scrub-dsssl-keys "missing value for keyword" arg) )
    145           (loop nxt (cons arg rest)) ) ) ) ) )
     133;(define keyword->symbol (o string->symbol keyword->string))
     134;(define keyword->uninterned-symbol (o string->uninterned-symbol keyword->string))
     135
     136(: ensure-keyword-list ((list-of symbol) --> (list-of symbol)))
     137;
     138(define (ensure-keyword-list kwds)
     139  (foldl
     140    (lambda (x a)
     141      (if (and (symbol? x) (not (keyword? x)))
     142        (cons (symbol->keyword x) a)
     143        a ) )
     144    '()
     145    kwds) )
     146
     147(: delete-keyword-arguments ((list-of symbol) list --> list))
     148;
     149; kwds = (list-of (or keyword symbol))
     150(define (delete-keyword-arguments kwds rest)
     151  (let ((kwds (ensure-keyword-list kwds)))
     152    (let loop ((args rest) (rest '()))
     153      (if (null? args)
     154        (reverse! rest)
     155        (let (
     156          (arg (car args))
     157          (nxt (cdr args)) )
     158          (if (memq arg kwds)
     159            (if (not (null? nxt))
     160              (loop (cdr nxt) rest)
     161              (error 'delete-keyword-arguments "premature end-of-list" arg rest kwds) )
     162            (loop nxt (cons arg rest)) ) ) ) ) ) )
     163
     164(: scrub-dsssl-keys deprecated)
     165(define scrub-dsssl-keys delete-keyword-arguments)
    146166
    147167) ;module dsssl-utils
  • release/4/dsssl-utils/trunk/dsssl-utils.setup

    r34913 r35201  
    55(verify-extension-name "dsssl-utils")
    66
    7 (setup-shared-extension-module 'typed-define (extension-version "2.1.1")
     7(setup-shared-extension-module 'typed-define (extension-version "2.2.0")
    88  #:inline? #t
    99  #:types? #t
     
    1414    -no-procedure-checks -no-bound-checks -no-argc-checks))
    1515
    16 (setup-shared-extension-module 'dsssl-utils (extension-version "2.1.1")
     16(setup-shared-extension-module 'dsssl-utils (extension-version "2.2.0")
    1717  #:inline? #t
    1818  #:types? #t
     
    2323    -no-procedure-checks -no-bound-checks))
    2424
    25 (setup-shared-extension-module 'lambda+ (extension-version "2.1.1")
     25(setup-shared-extension-module 'lambda+ (extension-version "2.2.0")
    2626  #:inline? #t
    2727  #:types? #t
  • release/4/dsssl-utils/trunk/lambda+.scm

    r34787 r35201  
    88  (lambda+ bind-lambda+))
    99
    10 (import scheme)
    11 
    12 (import chicken)
    13 
    14 (import (only srfi-1 append! reverse!))
    15 (require-library srfi-1)
     10(import scheme chicken)
     11
     12(use
     13  (only srfi-1 append! reverse!))
     14
     15;;
     16
     17#| ;These "push" visibly into the background
     18(define-syntax λ
     19  (syntax-rules ()
     20    ((_ ?arg0 ...) (lambda+ ?arg0 ...))))
     21
     22(define-syntax ^
     23  (syntax-rules ()
     24    ((_ ?arg0 ...) (lambda+ ?arg0 ...))))
     25|#
    1626
    1727;;
     
    157167;;
    158168
     169(define-for-syntax (symbol-only? obj)
     170  (and (symbol? obj) (not (keyword? obj))) )
     171
    159172(define-for-syntax (identifier? obj)
    160   (let ((sanobj (strip-syntax obj)))
    161     (and (symbol? sanobj)
    162          (not (keyword? sanobj))) ) )
     173  (symbol-only? (strip-syntax obj)) )
     174
     175(define-for-syntax (length=2? l)
     176  (and (pair? l) (pair? (cdr l)) (null? (cddr l))) )
    163177
    164178;;
     
    178192        (syntax-error 'lambda+ "invalid rest argument - not an identifier" args) )
    179193      (else
    180         (let ((arg (car args))
    181               (args (cdr args)) )
     194        (let (
     195          (arg (car args))
     196          (args (cdr args)) )
    182197          (case mode
    183198            ((required)
     
    202217                 (loop 'optional args rqrs (cons (cons arg #f) opts) rest keys) )
    203218                ((list? arg)
    204                   (if (and (pair? arg) (pair? (cdr arg)) (null? (cddr arg))
    205                            (identifier? (car arg)))
     219                  (if (and (identifier? (car arg)) (length=2? arg))
    206220                    (loop 'optional args rqrs (cons (cons (car arg) (cadr arg)) opts) rest keys)
    207221                    (syntax-error 'lambda+ "invalid optional argument specification" arg) ) )
     
    227241                 (loop 'key args rqrs opts rest (cons (cons arg #f) keys)) )
    228242                ((list? arg)
    229                   (if (and (pair? arg) (pair? (cdr arg)) (null? (cddr arg))
    230                            (identifier? (car arg)))
     243                  (if (and
     244                        (pair? arg) (pair? (cdr arg)) (null? (cddr arg))
     245                        (identifier? (car arg)))
    231246                    (loop 'key args rqrs opts rest (cons (cons (car arg) (cadr arg)) keys))
    232247                    (syntax-error 'lambda+ "invalid keyword argument specification" arg) ) )
     
    292307                  ((fx= size i) vec)
    293308                (vector-set! vec i (cdar keys)) ) ) ) )
    294         (let ((arg (car args))
    295               (args (cdr args)) )
     309        (let (
     310          (arg (car args))
     311          (args (cdr args)) )
    296312          (cond
    297313            ((and (keyword? arg) (assq arg keys))
  • release/4/dsssl-utils/trunk/tests/run.scm

    r35141 r35201  
    1 ;;;; dsssl-utils-test.scm -*- Hen -*-
    21
    3 (use test)
     2(define EGG-NAME "dsssl-utils")
    43
    5 ;;
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    65
    7 (test-begin "dssl-utils")
     6(use files)
    87
    9 ;;
     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")
    1010
     11(define *args* (argv))
    1112
    12 (use dsssl-utils)
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
    1315
    14 (test-group "dsssl-fixup"
     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") ) ) )
    1524
    16   (define (f a1 a2 #!optional (o1 'x) o2 #!rest rest #!key k1 k2)
    17     #; ;NOTE the variables are NEW in the dsssl-fixup body so before shot
    18     (print `(
    19       (a1 ,a1 a2 ,a2)
    20       (o1 ,o1 o2 ,o2)
    21       (#:k1 ,k1 #:k2 ,k2)
    22       (rest ,rest)))
    23     (dsssl-fixup ((o1 'x) o2) ((#:k1 k1) (#:k2 k2)) rest `(
    24       (a1 ,a1 a2 ,a2)
    25       (o1 ,o1 o2 ,o2)
    26       (#:k1 ,k1 #:k2 ,k2)
    27       (rest ,rest)) ) )
     25;;;
    2826
    29   (test '((a1 1 a2 2) (o1 3 o2 #f) (#:k1 4 #:k2 #f) (rest ())) (f 1 2 #:k1 4 3))
     27(set! EGG-NAME (egg-name))
    3028
    31   (test-error (f 1 2 3 #:k1 4 5 #:k2))
     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)) ) )
    3237
    33   (test '((a1 1 a2 2) (o1 4 o2 5) (#:k1 3 #:k2 6) (rest (7 8))) (f 1 2 #:k1 3 4 5 #:k2 6 7 8))
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
    3440
    35   (test '((a1 1 a2 2) (o1 3 o2 6) (#:k1 4 #:k2 5) (rest (7 8))) (f 1 2 3 #:k1 4 #:k2 5 6 7 8))
     41;;;
    3642
    37   (test '((a1 1 a2 2) (o1 3 o2 5) (#:k1 4 #:k2 6) (rest (7 8))) (f 1 2 3 #:k1 4 5 #:k2 6 7 8))
    38 
    39   (test '((a1 1 a2 2) (o1 3 o2 5) (#:k1 4 #:k2 6) (rest ())) (f 1 2 3 #:k1 4 5 #:k2 6))
    40 )
    41 
    42 ;;
    43 
    44 (use lambda+)
    45 
    46 (test-group "lambda+"
    47 
    48   (define (foo r1 r2 #!optional o1 (o2 '()) #!rest rest #!key k1 (k2 'foo))
    49     `((,r1 ,r2) (,o1 ,o2) (,k1 ,k2) ,rest))
    50 
    51   (define+ (foo+ r1 r2 #!optional o1 (o2 '()) #!rest rest #!key k1 (k2 'foo))
    52     `((,r1 ,r2) (,o1 ,o2) (,k1 ,k2) ,rest))
    53 
    54   (test '((1 2) (3 #:k1) (#f foo) (4 5 6 7 8)) (foo 1 2 3 #:k1 4 5 6 7 8))
    55 
    56   (test '((1 2) (3 5) (4 foo) (6 7 8)) (foo+ 1 2 3 #:k1 4 5 6 7 8))
    57 )
    58 
    59 ;;
    60 
    61 (use typed-define)
    62 
    63 (test-group "typed-define"
    64 
    65   (define: (atom-mutate!-2 (atm <atom>) (prc procedure) . (args (list-of *))) -> *
    66     #f )
    67 
    68   (define: (atom-mutate!-1 (atm <atom>) . (args (list-of *))) -> *
    69     #f )
    70 
    71   (define: (atom-mutate!-0 . (args (list-of *))) -> *
    72     #f )
    73 
    74   (test "only needs to expand" #f (atom-mutate!-2 (void) (void) 1 2 3))
    75   (test "only needs to expand" #f (atom-mutate!-1 (void) 1 2 3))
    76   (test "only needs to expand" #f (atom-mutate!-0 1 2 3))
    77 )
    78 
    79 (test-group "typed-define-record"
    80 
    81   (define:-record-type <trec>
    82     (make-trec a b c)
    83     trec?
    84     (a string trec-a)
    85     (b (or boolean number) trec-b trec-b-set!)
    86     (c immediate trec-c trec-c-set!) )
    87 
    88   (let ((trec (make-trec "a" #f #!eof)))
    89     (test-assert (trec? trec))
    90     (test #f (trec-b trec))
    91     (trec-b-set! trec 34)
    92     (test 34 (trec-b trec)) )
    93 )
    94 
    95 ;;
    96 
    97 (test-end "dssl-utils")
    98 
    99 ;;
    100 
    101 (test-exit)
     43(run-test)
  • release/4/dsssl-utils/trunk/typed-define.scm

    r35141 r35201  
    1616    ((_ ?tag (?ctor-id ?ctor-args ...) ?pred-id (?feld-var ?feld-typ ?feld-ref ...)  ...)
    1717      (begin
    18         (: ?ctor-id (#!rest --> (struct ?tag)))
    19         (: ?pred-id (* -> boolean : (struct ?tag)))
     18        (define-type ?tag (struct ?tag))
     19        (: ?ctor-id (#!rest --> ?tag))
     20        (: ?pred-id (* -> boolean : ?tag))
    2021        (type:-record-type-accessor ?tag (?feld-var ?feld-typ ?feld-ref ...)) ...
    2122        ;build type-dict from ?ctor-args ...
     
    7071        ?body ...) ) ) )
    7172
    72 ;;
     73;; typed scheme support
    7374
    7475(define-syntax type:-record-type-accessor
     
    8384        (: ?set ((struct ?tag) ?typ -> undefined)) ) ) ) )
    8485
    85 ;typed scheme support
    8686(define-syntax define:-procedure
    8787  (syntax-rules ()
Note: See TracChangeset for help on using the changeset viewer.