Changeset 38814 in project


Ignore:
Timestamp:
08/01/20 17:55:24 (9 days ago)
Author:
juergen
Message:

bindings 4.1 with bugfix

Location:
release/5/bindings
Files:
3 edited
4 copied

Legend:

Unmodified
Added
Removed
  • release/5/bindings/tags/4.1/bindings.egg

    r38805 r38814  
    44 (test-dependencies simple-tests biglists)
    55 (author "Juergen Lorenz")
    6  (version "4.0")
     6 (version "4.1")
    77 (components (extension bindings
    88                        (csc-options "-O3" "-d0"))))
  • release/5/bindings/tags/4.1/bindings.scm

    r38805 r38814  
    8888  string-cdr
    8989  string-null?
     90  resolve-dots
    9091  )
    9192
     
    122123       (not (null? xpr))
    123124       (dots? (car xpr))))
     125
     126;;; (a b cs ... d e)
     127;;; ->
     128;;; (append (a) (b) cs (d) (e))
     129;;; to be used in body
     130(define-syntax resolve-dots
     131  (ir-macro-transformer
     132    (lambda (form inject compare?)
     133      (let ((args (cdr form))
     134            (dots? (lambda (sym)
     135                     (or (compare? sym '..)
     136                         (compare? sym '...)
     137                         (compare? sym '....)))))
     138        (let ((lists (let loop ((args args) (result '()))
     139                       (let loop ((args args) (result '()))
     140                         (cond
     141                           ((null? args)
     142                            (reverse result))
     143                           ((null? (cdr args))
     144                            (if (dots? (car args))
     145                              (reverse result)
     146                              (reverse (cons `(list ,(car args)) result))))
     147                           (else
     148                             (cond
     149                               ((dots? (cadr args))
     150                                (loop (cdr args)
     151                                      (cons (car args) result)))
     152                               ((dots? (car args))
     153                                (loop (cdr args) result))
     154                               (else
     155                                (loop (cdr args)
     156                                      (cons `(list ,(car args))
     157                                            result)))))
     158                           )))))
     159          `(append ,@lists))))))
    124160
    125161;;; (bind-listify*)
     
    380416;;; (bind pat seq . body)
    381417;;; ---------------------
     418;;; Note, that the destructuring of pat and seq happen at different
     419;;; times: The former at compile-time, the latter at run-time.
     420;;; Consequently, some code in bind almost duplicates some code in
     421;;; bind-listify*.
    382422(define-syntax bind
    383423  (er-macro-transformer
     
    387427        (seq (caddr form))
    388428        (body (cdddr form))
     429        (%_ (rename '_))
    389430        (%bind-list (rename 'bind-list))
    390431        (%bind-listify* (rename 'bind-listify*))
     
    408449                  ((null? pat)
    409450                   (reverse result))
    410                   ((and (symbol? pat) (eq? pat '_));(compare? pat %_))
     451                  ((and (symbol? pat) ;(eq? pat '_))
     452                        (compare? pat %_))
    411453                   (reverse result))
    412454                  ((symbol? pat)
     
    414456                  ((literal? pat)
    415457                   (reverse result))
     458                  ((and (pair? pat) (dotted-list? (cdr pat)))
     459                   (let ((first (car pat)) (rest (cdr pat)))
     460                     (cond
     461                       ((and (symbol? first) (eq? first '_))
     462                        (error 'bind "dots mustn't follow wildcard"))
     463                       ((symbol? first)
     464                        (loop (cdr rest) (cons first result)))
     465                       ((literal? first)
     466                        (error 'bind "dots mustn't follow literal"))
     467                       ((pair? first)
     468                        (loop (cdr rest) (cons (listify* first) result)))
     469                       )))
    416470                  ((pair? pat)
    417471                   (let ((first (car pat)) (rest (cdr pat)))
    418                      (if (dotted-list? (cdr pat))
    419                        (cond
    420                          ((and (symbol? first) (eq? first '_))
    421                           (error 'bind "dots mustn't follow wildcard"))
    422                          ((symbol? first)
    423                           (loop (cdr rest) (cons first result)))
    424                          ((literal? first)
    425                           (error 'bind "dots mustn't follow literal"))
    426                          ((pair? first)
    427                           (loop (cdr rest) (cons (listify* first) result)))
    428                          )
    429                        (cond
    430                          ((and (symbol? first)
    431                                (eq? first '_));(compare? first %_))
    432                           (loop rest result))
    433                          ((symbol? first)
    434                           (loop rest (cons first result)))
    435                          ((null? first) ;;;
    436                           (loop rest (cons first result)))
    437                          ((literal? first)
    438                           (loop rest result))
    439                          ((pair? first)
    440                           (loop rest (cons (listify* first) result)))
    441                          ))))))))
     472                     (cond
     473                       ((and (symbol? first) ;(eq? first '_))
     474                             (compare? first %_))
     475                        (loop rest result))
     476                       ((symbol? first)
     477                        (loop rest (cons first result)))
     478                       ((null? first) ;;;
     479                        (loop rest (cons first result)))
     480                       ((literal? first)
     481                        (loop rest result))
     482                       ((pair? first)
     483                        (loop rest (cons (listify* first) result)))
     484                       )))
     485                  ))))
    442486          )
    443487          (if (null? body)
     
    498542
    499543  (bind-case '(1 (2 3))
    500     ((x y) (>> y list?) (list x y))
     544    ((x y) (where (number? y)) (list x y))
    501545    ((x (y . z)) (list x y z))
    502546    ((x (y z)) (list x y z))) ;-> '(1 2 (3))
     
    874918      "binds cc to the current contiunation"
    875919      "and execute xpr ... in this context")
     920    (resolve-dots
     921      macro:
     922      (resolve-dots . args)
     923      "where args is a list of items which might be followed by dots."
     924      "The item before dots must be a list, which is spliced into"
     925      "the resulting list removing the dots")
    876926    (vector-car
    877927      procedure:
     
    882932      (vector-cdr vec)
    883933      "vector-analog of cdr")
     934    (vector-null?
     935      procedure:
     936      (vector-null? vec)
     937      "vector-analog of null?")
    884938    (string-car
    885939      procedure:
    886       (string-car vec)
     940      (string-car str)
    887941      "string-analog of car")
    888942    (string-cdr
    889943      procedure:
    890       (string-cdr vec)
     944      (string-cdr str)
    891945      "string-analog of cdr")
     946    (string-null?
     947      procedure:
     948      (string-null? str)
     949      "string-analog of null?")
    892950    )))
    893951
     
    895953
    896954;(import bindings simple-tests)
    897 ;( bind-listify* vector? vector-car vector-cdr)
    898 ;(ppp
    899 ;  (bind (a (b . cs) . ds)
    900 ;        '(1 #(20 30 40) 2 3)
    901 ;    (list a b cs ds))
    902 ;  (bind (a (b cs ...) ds ...)
    903 ;        '(1 #(20 30 40) 2 3)
    904 ;    (list a b cs ds))
    905 ;  ((bind-lambda (a (b cs ...) ds ...)
    906 ;     (list a b cs ds))
    907 ;   '(1 #(20 30 40) 2 3))
    908 ;  )
    909 ;;(ppp
    910 ;;  (bind-listify* '(as ... b c) '(1 2 3 40 50))
    911 ;;  (bind-listify* '(as ... b c) '(40 50))
    912 ;;  (bind-listify* '(x y as ... b c) '(-2 -1 1 2 3 40 50))
    913 ;;  (bind-listify* '(x y as ... b c) '(-2 -1 40 50)) ; as might be null
    914 ;;  (bind-listify* '(a b c) '(1 2 3))
    915 ;;  (bind-listify* '((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5))
    916 ;;  (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5))
    917 ;;  )
    918 ;;
    919 ;(newline)
    920 ;;(pe '(bind (as ... d e) '(1 2 3 4 5) #f))
    921 ;(ppp (bind (as ... d e) '(1 2 3 4 5) (list as d e)))
    922 ;(ppp (bind (x y as ... d e) '(-1 0 1 2 3 4 5) (list x y as d e)))
    923 ;(ppp (bind (x y as .. d e) '(-1 0 4 5)  (list x y as d e)))
    924 ;(newline)
    925 ;;(pe '(bind ((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5) #f))
    926 ;(ppp (bind ((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5)
    927 ;           (list as bs cs d e)))
    928 ;(newline)
    929 ;;(pe '(bind (x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5) #f))
    930 ;(ppp (bind (x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5)
    931 ;           (list x y as bs cs d e)))
    932 ;(newline)
    933 ;;(bind-listify* string? string-car string-cdr string-null?)
    934 ;(bind-listify* vector? vector-car vector-cdr vector-null?)
    935 ;(ppp (bind (u (x y (as (bs cs)) ... d e) v) ; should be wrong: ok
    936 ;           '(100 #(-1 0 4 5) 200)
    937 ;           (list u x y as bs cs d e v)))
    938 ;;(ppp (bind (u (x y (as (bs cs)) .... d e) v) ; should be wrong: ok
    939 ;;           '(100 #(-1 0 4 5) 200)
    940 ;;           (list u x y as bs cs d e v)))
    941 ;;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
    942 ;;           '(100 (-1 0 (1 2 3) 4 5) 200) ; should be wrong: ok
    943 ;;           (list u x y as bs cs d e v)))
    944 ;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
    945 ;           '(100 (-1 0 (1 (2 3)) (10 (20 30)) 4 5) 200)
    946 ;           (list u x y as bs cs d e v)))
    947 ;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
    948 ;           '(100 (-1 0 (1 (2 3)) #(10 (20 30)) 4 5) 200)
    949 ;           (list u x y as bs cs d e v)))
    950 ;;
    951 ;;;(ppp (bind-listify* '(1 2 3))
    952 ;;;     (bind-listify* "x")
    953 ;;;     (bind-listify* '(a . b) #(1 2 3))
    954 ;;;     )
    955 ;;;(pe '(bind-list (a (b c)) '(1 (2 3))))
    956 ;;;(pe '(bind-list (a (b c) d) '(1 (2 3) 4)))
    957 ;;;(pe '(bind-list (a (b (c d))) '(1 (2 (3 4)))))
    958 ;;;(pe '(bind-list (a b) '(1)))
    959 ;;
     955
  • release/5/bindings/tags/4.1/tests/run.scm

    r38805 r38814  
    674674;(biglists?)
    675675
     676(define-checks (dots? verbose?)
     677  (resolve-dots '(1 2 3) ...)
     678  '(1 2 3)
     679  (resolve-dots 1 2 '(30 40) .. 5)
     680  '(1 2 30 40 5)
     681  (resolve-dots 1 2 '() .. 5)
     682  '(1 2 5)
     683  (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7)
     684  '(1 20 30 4 40 50 60 7)
     685)
     686;(dots?)
     687
    676688(check-all BINDINGS
    677689  (listify?)
     
    684696  (lets?)
    685697  (biglists?)
    686   )
    687 
     698  (dots?)
     699  )
     700
  • release/5/bindings/trunk/bindings.egg

    r38805 r38814  
    44 (test-dependencies simple-tests biglists)
    55 (author "Juergen Lorenz")
    6  (version "4.0")
     6 (version "4.1")
    77 (components (extension bindings
    88                        (csc-options "-O3" "-d0"))))
  • release/5/bindings/trunk/bindings.scm

    r38805 r38814  
    8888  string-cdr
    8989  string-null?
     90  resolve-dots
    9091  )
    9192
     
    122123       (not (null? xpr))
    123124       (dots? (car xpr))))
     125
     126;;; (a b cs ... d e)
     127;;; ->
     128;;; (append (a) (b) cs (d) (e))
     129;;; to be used in body
     130(define-syntax resolve-dots
     131  (ir-macro-transformer
     132    (lambda (form inject compare?)
     133      (let ((args (cdr form))
     134            (dots? (lambda (sym)
     135                     (or (compare? sym '..)
     136                         (compare? sym '...)
     137                         (compare? sym '....)))))
     138        (let ((lists (let loop ((args args) (result '()))
     139                       (let loop ((args args) (result '()))
     140                         (cond
     141                           ((null? args)
     142                            (reverse result))
     143                           ((null? (cdr args))
     144                            (if (dots? (car args))
     145                              (reverse result)
     146                              (reverse (cons `(list ,(car args)) result))))
     147                           (else
     148                             (cond
     149                               ((dots? (cadr args))
     150                                (loop (cdr args)
     151                                      (cons (car args) result)))
     152                               ((dots? (car args))
     153                                (loop (cdr args) result))
     154                               (else
     155                                (loop (cdr args)
     156                                      (cons `(list ,(car args))
     157                                            result)))))
     158                           )))))
     159          `(append ,@lists))))))
    124160
    125161;;; (bind-listify*)
     
    380416;;; (bind pat seq . body)
    381417;;; ---------------------
     418;;; Note, that the destructuring of pat and seq happen at different
     419;;; times: The former at compile-time, the latter at run-time.
     420;;; Consequently, some code in bind almost duplicates some code in
     421;;; bind-listify*.
    382422(define-syntax bind
    383423  (er-macro-transformer
     
    387427        (seq (caddr form))
    388428        (body (cdddr form))
     429        (%_ (rename '_))
    389430        (%bind-list (rename 'bind-list))
    390431        (%bind-listify* (rename 'bind-listify*))
     
    408449                  ((null? pat)
    409450                   (reverse result))
    410                   ((and (symbol? pat) (eq? pat '_));(compare? pat %_))
     451                  ((and (symbol? pat) ;(eq? pat '_))
     452                        (compare? pat %_))
    411453                   (reverse result))
    412454                  ((symbol? pat)
     
    414456                  ((literal? pat)
    415457                   (reverse result))
     458                  ((and (pair? pat) (dotted-list? (cdr pat)))
     459                   (let ((first (car pat)) (rest (cdr pat)))
     460                     (cond
     461                       ((and (symbol? first) (eq? first '_))
     462                        (error 'bind "dots mustn't follow wildcard"))
     463                       ((symbol? first)
     464                        (loop (cdr rest) (cons first result)))
     465                       ((literal? first)
     466                        (error 'bind "dots mustn't follow literal"))
     467                       ((pair? first)
     468                        (loop (cdr rest) (cons (listify* first) result)))
     469                       )))
    416470                  ((pair? pat)
    417471                   (let ((first (car pat)) (rest (cdr pat)))
    418                      (if (dotted-list? (cdr pat))
    419                        (cond
    420                          ((and (symbol? first) (eq? first '_))
    421                           (error 'bind "dots mustn't follow wildcard"))
    422                          ((symbol? first)
    423                           (loop (cdr rest) (cons first result)))
    424                          ((literal? first)
    425                           (error 'bind "dots mustn't follow literal"))
    426                          ((pair? first)
    427                           (loop (cdr rest) (cons (listify* first) result)))
    428                          )
    429                        (cond
    430                          ((and (symbol? first)
    431                                (eq? first '_));(compare? first %_))
    432                           (loop rest result))
    433                          ((symbol? first)
    434                           (loop rest (cons first result)))
    435                          ((null? first) ;;;
    436                           (loop rest (cons first result)))
    437                          ((literal? first)
    438                           (loop rest result))
    439                          ((pair? first)
    440                           (loop rest (cons (listify* first) result)))
    441                          ))))))))
     472                     (cond
     473                       ((and (symbol? first) ;(eq? first '_))
     474                             (compare? first %_))
     475                        (loop rest result))
     476                       ((symbol? first)
     477                        (loop rest (cons first result)))
     478                       ((null? first) ;;;
     479                        (loop rest (cons first result)))
     480                       ((literal? first)
     481                        (loop rest result))
     482                       ((pair? first)
     483                        (loop rest (cons (listify* first) result)))
     484                       )))
     485                  ))))
    442486          )
    443487          (if (null? body)
     
    498542
    499543  (bind-case '(1 (2 3))
    500     ((x y) (>> y list?) (list x y))
     544    ((x y) (where (number? y)) (list x y))
    501545    ((x (y . z)) (list x y z))
    502546    ((x (y z)) (list x y z))) ;-> '(1 2 (3))
     
    874918      "binds cc to the current contiunation"
    875919      "and execute xpr ... in this context")
     920    (resolve-dots
     921      macro:
     922      (resolve-dots . args)
     923      "where args is a list of items which might be followed by dots."
     924      "The item before dots must be a list, which is spliced into"
     925      "the resulting list removing the dots")
    876926    (vector-car
    877927      procedure:
     
    882932      (vector-cdr vec)
    883933      "vector-analog of cdr")
     934    (vector-null?
     935      procedure:
     936      (vector-null? vec)
     937      "vector-analog of null?")
    884938    (string-car
    885939      procedure:
    886       (string-car vec)
     940      (string-car str)
    887941      "string-analog of car")
    888942    (string-cdr
    889943      procedure:
    890       (string-cdr vec)
     944      (string-cdr str)
    891945      "string-analog of cdr")
     946    (string-null?
     947      procedure:
     948      (string-null? str)
     949      "string-analog of null?")
    892950    )))
    893951
     
    895953
    896954;(import bindings simple-tests)
    897 ;( bind-listify* vector? vector-car vector-cdr)
    898 ;(ppp
    899 ;  (bind (a (b . cs) . ds)
    900 ;        '(1 #(20 30 40) 2 3)
    901 ;    (list a b cs ds))
    902 ;  (bind (a (b cs ...) ds ...)
    903 ;        '(1 #(20 30 40) 2 3)
    904 ;    (list a b cs ds))
    905 ;  ((bind-lambda (a (b cs ...) ds ...)
    906 ;     (list a b cs ds))
    907 ;   '(1 #(20 30 40) 2 3))
    908 ;  )
    909 ;;(ppp
    910 ;;  (bind-listify* '(as ... b c) '(1 2 3 40 50))
    911 ;;  (bind-listify* '(as ... b c) '(40 50))
    912 ;;  (bind-listify* '(x y as ... b c) '(-2 -1 1 2 3 40 50))
    913 ;;  (bind-listify* '(x y as ... b c) '(-2 -1 40 50)) ; as might be null
    914 ;;  (bind-listify* '(a b c) '(1 2 3))
    915 ;;  (bind-listify* '((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5))
    916 ;;  (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5))
    917 ;;  )
    918 ;;
    919 ;(newline)
    920 ;;(pe '(bind (as ... d e) '(1 2 3 4 5) #f))
    921 ;(ppp (bind (as ... d e) '(1 2 3 4 5) (list as d e)))
    922 ;(ppp (bind (x y as ... d e) '(-1 0 1 2 3 4 5) (list x y as d e)))
    923 ;(ppp (bind (x y as .. d e) '(-1 0 4 5)  (list x y as d e)))
    924 ;(newline)
    925 ;;(pe '(bind ((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5) #f))
    926 ;(ppp (bind ((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5)
    927 ;           (list as bs cs d e)))
    928 ;(newline)
    929 ;;(pe '(bind (x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5) #f))
    930 ;(ppp (bind (x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5)
    931 ;           (list x y as bs cs d e)))
    932 ;(newline)
    933 ;;(bind-listify* string? string-car string-cdr string-null?)
    934 ;(bind-listify* vector? vector-car vector-cdr vector-null?)
    935 ;(ppp (bind (u (x y (as (bs cs)) ... d e) v) ; should be wrong: ok
    936 ;           '(100 #(-1 0 4 5) 200)
    937 ;           (list u x y as bs cs d e v)))
    938 ;;(ppp (bind (u (x y (as (bs cs)) .... d e) v) ; should be wrong: ok
    939 ;;           '(100 #(-1 0 4 5) 200)
    940 ;;           (list u x y as bs cs d e v)))
    941 ;;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
    942 ;;           '(100 (-1 0 (1 2 3) 4 5) 200) ; should be wrong: ok
    943 ;;           (list u x y as bs cs d e v)))
    944 ;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
    945 ;           '(100 (-1 0 (1 (2 3)) (10 (20 30)) 4 5) 200)
    946 ;           (list u x y as bs cs d e v)))
    947 ;(ppp (bind (u (x y (as (bs cs)) ... d e) v)
    948 ;           '(100 (-1 0 (1 (2 3)) #(10 (20 30)) 4 5) 200)
    949 ;           (list u x y as bs cs d e v)))
    950 ;;
    951 ;;;(ppp (bind-listify* '(1 2 3))
    952 ;;;     (bind-listify* "x")
    953 ;;;     (bind-listify* '(a . b) #(1 2 3))
    954 ;;;     )
    955 ;;;(pe '(bind-list (a (b c)) '(1 (2 3))))
    956 ;;;(pe '(bind-list (a (b c) d) '(1 (2 3) 4)))
    957 ;;;(pe '(bind-list (a (b (c d))) '(1 (2 (3 4)))))
    958 ;;;(pe '(bind-list (a b) '(1)))
    959 ;;
     955
  • release/5/bindings/trunk/tests/run.scm

    r38805 r38814  
    674674;(biglists?)
    675675
     676(define-checks (dots? verbose?)
     677  (resolve-dots '(1 2 3) ...)
     678  '(1 2 3)
     679  (resolve-dots 1 2 '(30 40) .. 5)
     680  '(1 2 30 40 5)
     681  (resolve-dots 1 2 '() .. 5)
     682  '(1 2 5)
     683  (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7)
     684  '(1 20 30 4 40 50 60 7)
     685)
     686;(dots?)
     687
    676688(check-all BINDINGS
    677689  (listify?)
     
    684696  (lets?)
    685697  (biglists?)
    686   )
    687 
     698  (dots?)
     699  )
     700
Note: See TracChangeset for help on using the changeset viewer.