Changeset 35748 in project


Ignore:
Timestamp:
07/05/18 04:41:05 (2 weeks ago)
Author:
kon
Message:

better name, reflow, comments

Location:
release/4/dsssl-utils/trunk
Files:
3 edited

Legend:

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

    r35210 r35748  
    1616  (only srfi-1 append! reverse!)
    1717  (only symbol-utils symbol->keyword))
     18
     19;;
     20
     21#;
     22;((let-keyword-optionals opts ident1 (ident2 #t) ...)
     23; ...)
     24;=>
     25;(let-values (
     26; ((ident1 ident2 ...)
     27;   (keyword-optional-values opts #:ident1 (#:ident2 #t) ...)))
     28; ...)
     29(define-syntax let-keyword-optionals
     30  )
    1831
    1932;; DSSSL Extended Lambda List fixup
     
    131144;; Returns the argument list w/o key+val pairs
    132145
    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 syms)
    139   (foldl
    140     (lambda (a x)
    141       (let (
    142         (kwd
    143           (if (and (symbol? x) (not (keyword? x)))
    144             (symbol->keyword x)
    145             x ) ) )
    146         (cons kwd a) ) )
    147     '()
    148     syms) )
    149 
    150146(: delete-keyword-arguments ((list-of symbol) list --> list))
    151147;
     
    165161            (loop nxt (cons arg rest)) ) ) ) ) ) )
    166162
    167 (: scrub-dsssl-keys deprecated)
     163(: ensure-keyword-list ((list-of symbol) --> (list-of symbol)))
     164;
     165(define (ensure-keyword-list syms)
     166  (foldl
     167    (lambda (a x)
     168      (let (
     169        (kwd
     170          (if (and (symbol? x) (not (keyword? x)))
     171            (symbol->keyword x)
     172            x ) ) )
     173        (cons kwd a) ) )
     174    '()
     175    syms) )
     176
     177;;
     178
     179(: scrub-dsssl-keys (deprecated delete-keyword-arguments))
    168180(define scrub-dsssl-keys delete-keyword-arguments)
    169181
  • release/4/dsssl-utils/trunk/lambda+.scm

    r35201 r35748  
    7979                  (map
    8080                    (lambda (x)
    81                       (cons (string->keyword (##sys#symbol->string (car x))) (cdr x)))
     81                      (cons (string->keyword (symbol->string (car x))) (cdr x)))
    8282                     keys)))
    8383            ; actual lambda
     
    9999
    100100(define-syntax (lambda+ f r c)
    101   (let ((args (cadr f))
    102         (body (cddr f))
    103         (r_restargs (r 'restargs))
    104         (r__ (r '_))
    105         (r_valvec (r 'valvec))
    106         (r_lambda (r 'lambda))
    107         (r_vector-ref (r 'vector-ref))
    108         (r_bind-lambda+ (r 'bind-lambda+))
    109         (r_call-with-values (r 'call-with-values))
    110         (r_list (r 'list)) )
    111     (call-with-values
    112       (lambda () (parse-lambda+ args))
    113       (lambda (rqrs opts rstvar keys)
    114         (let* ((optslen (length opts))
    115                (keyslen (length keys))
    116                (keypos (fx+ optslen 1))
    117                (size (fx+ keypos keyslen))
    118                (optvars (map car opts))
    119                (optdefs (map cdr opts))
    120                (keyvars (map car keys))
    121                ; make keywords for matching
    122                (kwds
    123                 (map
    124                   (lambda (p)
    125                     (cons
    126                       (string->keyword (##sys#symbol->string (car p)))
    127                       (cdr p)) )
    128                    keys)) )
    129           ; actual lambda
    130           (cond
    131             ; simple
    132             ((and (null? opts) (null? keys))
    133               (if (not rstvar) `(,r_lambda (,@rqrs) ,@body)
    134                 `(,r_lambda ,(if (null? rqrs) rstvar `(,@rqrs . ,rstvar))
    135                   ,@body ) ) )
    136             ; complex
    137             (else
    138               `(,r_lambda ,(if (null? rqrs) r_restargs `(,@rqrs . ,r_restargs))
    139                 (let ((,r_valvec
    140                         (,r_bind-lambda+
    141                           ,optslen ,keypos ,size
    142                           (,r_list ,@optdefs)
    143                           (,r_list ,@(map (lambda (l) `(cons ,(car l) ,(cdr l))) kwds))
    144                           ',rstvar
    145                           ,r_restargs)))
    146                   (let ((,(or rstvar r__) (vector-ref ,r_valvec 0))
    147                         ,@(let loop ((idx 1)
    148                                      (optvars optvars)
    149                                      (letspc '()))
    150                             (if (null? optvars) letspc
    151                               (loop (fx+ idx 1)
    152                                     (cdr optvars)
    153                                     (cons
    154                                       `(,(car optvars) (,r_vector-ref ,r_valvec ,idx))
    155                                       letspc)) ) )
    156                         ,@(let loop ((idx (fx+ optslen 1))
    157                                      (keyvars keyvars)
    158                                      (letspc '()))
    159                             (if (null? keyvars) letspc
    160                               (loop (fx+ idx 1)
    161                                     (cdr keyvars)
    162                                     (cons
    163                                       `(,(car keyvars) (,r_vector-ref ,r_valvec ,idx))
    164                                       letspc)) ) ) )
    165                     ,@body ) ) ) ) ) ) ) ) ) )
     101  (let (
     102    (args (cadr f))
     103    (body (cddr f))
     104    (r_restargs (r 'restargs))
     105    (r__ (r '_))
     106    (r_valvec (r 'valvec))
     107    (r_lambda (r 'lambda))
     108    (r_vector-ref (r 'vector-ref))
     109    (r_bind-lambda+ (r 'bind-lambda+))
     110    (r_list (r 'list)) )
     111    (let-values (
     112      ((rqrs opts rstvar keys) (parse-lambda+ args)) )
     113      (let* (
     114        (optslen (length opts))
     115        (keyslen (length keys))
     116        (keypos (fx+ optslen 1))
     117        (size (fx+ keypos keyslen))
     118        (optvars (map car opts))
     119        (optdefs (map cdr opts))
     120        (keyvars (map car keys))
     121        ; make keywords for matching
     122        (kwds
     123          (map
     124            (lambda (p)
     125              (cons
     126                (string->keyword (symbol->string (car p)))
     127                (cdr p)) )
     128             keys)) )
     129        ; actual lambda
     130        (cond
     131          ; simple
     132          ((and (null? opts) (null? keys))
     133            (if (not rstvar)
     134              `(,r_lambda (,@rqrs) ,@body)
     135              `(,r_lambda ,(if (null? rqrs) rstvar `(,@rqrs . ,rstvar))
     136                ,@body ) ) )
     137          ; complex
     138          (else
     139            `(,r_lambda ,(if (null? rqrs) r_restargs `(,@rqrs . ,r_restargs))
     140              (let (
     141                (,r_valvec
     142                  (,r_bind-lambda+
     143                    ,optslen ,keypos ,size
     144                    (,r_list ,@optdefs)
     145                    (,r_list ,@(map (lambda (l) `(cons ,(car l) ,(cdr l))) kwds))
     146                    ',rstvar
     147                    ,r_restargs)) )
     148                (let ((,(or rstvar r__) (vector-ref ,r_valvec 0))
     149                      ,@(let loop ((idx 1) (optvars optvars) (letspc '()))
     150                          (if (null? optvars)
     151                            letspc
     152                            (loop
     153                              (fx+ idx 1)
     154                              (cdr optvars)
     155                              (cons
     156                                `(,(car optvars) (,r_vector-ref ,r_valvec ,idx))
     157                                letspc)) ) )
     158                      ,@(let loop (
     159                          (idx (fx+ optslen 1))
     160                          (keyvars keyvars)
     161                          (letspc '()) )
     162                          (if (null? keyvars)
     163                            letspc
     164                            (loop
     165                              (fx+ idx 1)
     166                              (cdr keyvars)
     167                              (cons
     168                                `(,(car keyvars) (,r_vector-ref ,r_valvec ,idx))
     169                                letspc)) ) ) )
     170                  ,@body ) ) ) ) ) ) ) ) )
    166171
    167172;;
  • release/4/dsssl-utils/trunk/typed-define.scm

    r35201 r35748  
    8484        (: ?set ((struct ?tag) ?typ -> undefined)) ) ) ) )
    8585
     86;FIXME ?rt must support (type ...) for multi-valued
    8687(define-syntax define:-procedure
    8788  (syntax-rules ()
Note: See TracChangeset for help on using the changeset viewer.