Changeset 35031 in project


Ignore:
Timestamp:
01/18/18 17:20:05 (7 months ago)
Author:
juergen
Message:

basic-macros 1.3 with pseudo-list-of

Location:
release/4/basic-macros
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/basic-macros/tags/1.3/basic-macros.scm

    r34873 r35031  
    11;Author: Juergen Lorenz ; ju (at) jugilo (dot) de
     2
    23;
    3 ; Copyright (c) 2017, Juergen Lorenz
     4; Copyright (c) 2017-2018, Juergen Lorenz
    45; All rights reserved.
    56;
     
    99100]|#
    100101
    101 (module basic-macro-helpers *
     102(module basic-macro-helpers ;*
     103  (basic-macro-helpers pseudo-list pseudo-list? pseudo-list-of
     104   pseudo-null? pseudo-length pseudo-head pseudo-tail pseudo-ref
     105   pseudo-sentinel pseudo-flatten
     106   remove-duplicates adjoin filter sym-prepends? sym-tail)
     107
    102108  (import scheme
    103109          (only chicken case-lambda assert print error))
     
    110116
    111117(define (pseudo-list? xpr)
    112   #t)
     118  (not (list? xpr)))
     119 ; #t)
     120
     121(define (my-conjoin . preds)
     122  (let recur ((preds preds))
     123    (lambda (xpr)
     124      (cond
     125        ((null? preds) #t)
     126        (((car preds) xpr)
     127         ((recur (cdr preds)) xpr))
     128        (else #f)))))
     129
     130(define (pseudo-list-of . preds)
     131  (let ((ok? (apply my-conjoin preds)))
     132    (lambda (xpr)
     133      (if (pair? xpr)
     134        (and (ok? (car xpr))
     135             ((pseudo-list-of ok?) (cdr xpr)))
     136        (ok? xpr)))))
    113137
    114138(define (pseudo-null? xpr)
     
    137161     (pseudo-ref (cdr pl) (- n 1)))))
    138162
    139 (define (pseudo-tail pl n)
    140   (assert (<= n (pseudo-length pl)))
    141   (cond
    142     ((not (pair? pl)) pl)
    143     ((= n 0) pl)
    144     (else
    145      (pseudo-tail (cdr pl) (- n 1)))))
    146 
    147 (define (pseudo-head pl n)
    148   (assert (<= n (pseudo-length pl)))
    149   (if (not (pair? pl))
    150     '()
    151     (let loop ((k 0) (pl pl) (result '()))
    152       (if (= k n)
    153         (reverse result)
    154         (loop (+ k 1) (cdr pl) (cons (car pl) result))))))
     163(define pseudo-tail
     164  (case-lambda
     165    ((pl n)
     166     (assert (<= n (pseudo-length pl)))
     167     (let loop ((pl pl) (n n))
     168       (cond
     169         ((not (pair? pl)) pl)
     170         ((= n 0) pl)
     171         (else
     172          (loop (cdr pl) (- n 1))))))
     173    ((pl)
     174     (pseudo-tail pl (pseudo-length pl)))))
     175
     176(define pseudo-head
     177  (case-lambda
     178    ((pl n)
     179     (assert (<= n (pseudo-length pl)))
     180     (if (not (pair? pl))
     181       '()
     182       (let loop ((k 0) (pl pl) (result '()))
     183         (if (= k n)
     184           (reverse result)
     185           (loop (+ k 1) (cdr pl) (cons (car pl) result))))))
     186    ((pl)
     187     (pseudo-head pl (pseudo-length pl)))))
    155188
    156189(define (pseudo-flatten tree)
     
    214247        (pseudo-list? xpr)
    215248        "is xpr a pseudo-list?"
    216         "returns always #t")
     249        "i.e. not a list?")
     250    (pseudo-list-of
     251      procedure:
     252      (pseudo-list-of . preds)
     253      "returns a unary predicate, which checks"
     254      "if its argument passes each predicate in preds")
    217255    (pseudo-null?
    218256      procedure:
     
    237275      procedure:
    238276        (pseudo-tail pl n)
     277        (pseudo-tail pl)
    239278        "returns the tail of pl starting with index n, where n is"
    240         "less than or equal to pl's pseudo-length")
     279        "less than or equal to pl's pseudo-length,"
     280        "if n is not provided, pl's pseudo-length is assumed")
    241281    (pseudo-head
    242282      procedure:
    243283        (pseudo-head pl n)
     284        (pseudo-head pl)
    244285        "returns the head of pl up to but excluding index n,"
    245         "where n is less than or equal to pl's pseudo-length")
     286        "where n is less than or equal to pl's pseudo-length;"
     287        "if n is not provided, pl's pseudo-length is assumed")
    246288    (pseudo-flatten
    247289      procedure:
  • release/4/basic-macros/tags/1.3/basic-macros.setup

    r34873 r35031  
    1010   "basic-macros.import.so"
    1111   "basic-macro-helpers.import.so")
    12  '((version "1.2")))
     12 '((version "1.3")))
  • release/4/basic-macros/tags/1.3/tests/run.scm

    r34857 r35031  
    3737  (check
    3838    (pseudo-list? "x")
     39    (pseudo-list? '(a b . c))
     40    (not (pseudo-list? '()))
     41    (not (pseudo-list? '(a b c)))
    3942    (pseudo-null? 5)
     43    ((pseudo-list-of) "x")
     44    ((pseudo-list-of symbol?) '(a b . c))
    4045    (equal? (pseudo-list #f 1 2 3 4)
    4146            '(1 2 3 4 . #f))
     
    4651    (equal? (pseudo-head '(0 . 1) 0) '())
    4752    (equal? (pseudo-head '(0 . 1) 1) '(0))
     53    (equal? (pseudo-head '(0 . 1)) '(0))
     54    (= (pseudo-tail '(0 . 1)) 1)
    4855    (not (condition-case (pseudo-ref 1 0)
    4956           ((exn) #f)))
  • release/4/basic-macros/trunk/basic-macros.scm

    r34873 r35031  
    11;Author: Juergen Lorenz ; ju (at) jugilo (dot) de
     2
    23;
    3 ; Copyright (c) 2017, Juergen Lorenz
     4; Copyright (c) 2017-2018, Juergen Lorenz
    45; All rights reserved.
    56;
     
    99100]|#
    100101
    101 (module basic-macro-helpers *
     102(module basic-macro-helpers ;*
     103  (basic-macro-helpers pseudo-list pseudo-list? pseudo-list-of
     104   pseudo-null? pseudo-length pseudo-head pseudo-tail pseudo-ref
     105   pseudo-sentinel pseudo-flatten
     106   remove-duplicates adjoin filter sym-prepends? sym-tail)
     107
    102108  (import scheme
    103109          (only chicken case-lambda assert print error))
     
    110116
    111117(define (pseudo-list? xpr)
    112   #t)
     118  (not (list? xpr)))
     119 ; #t)
     120
     121(define (my-conjoin . preds)
     122  (let recur ((preds preds))
     123    (lambda (xpr)
     124      (cond
     125        ((null? preds) #t)
     126        (((car preds) xpr)
     127         ((recur (cdr preds)) xpr))
     128        (else #f)))))
     129
     130(define (pseudo-list-of . preds)
     131  (let ((ok? (apply my-conjoin preds)))
     132    (lambda (xpr)
     133      (if (pair? xpr)
     134        (and (ok? (car xpr))
     135             ((pseudo-list-of ok?) (cdr xpr)))
     136        (ok? xpr)))))
    113137
    114138(define (pseudo-null? xpr)
     
    137161     (pseudo-ref (cdr pl) (- n 1)))))
    138162
    139 (define (pseudo-tail pl n)
    140   (assert (<= n (pseudo-length pl)))
    141   (cond
    142     ((not (pair? pl)) pl)
    143     ((= n 0) pl)
    144     (else
    145      (pseudo-tail (cdr pl) (- n 1)))))
    146 
    147 (define (pseudo-head pl n)
    148   (assert (<= n (pseudo-length pl)))
    149   (if (not (pair? pl))
    150     '()
    151     (let loop ((k 0) (pl pl) (result '()))
    152       (if (= k n)
    153         (reverse result)
    154         (loop (+ k 1) (cdr pl) (cons (car pl) result))))))
     163(define pseudo-tail
     164  (case-lambda
     165    ((pl n)
     166     (assert (<= n (pseudo-length pl)))
     167     (let loop ((pl pl) (n n))
     168       (cond
     169         ((not (pair? pl)) pl)
     170         ((= n 0) pl)
     171         (else
     172          (loop (cdr pl) (- n 1))))))
     173    ((pl)
     174     (pseudo-tail pl (pseudo-length pl)))))
     175
     176(define pseudo-head
     177  (case-lambda
     178    ((pl n)
     179     (assert (<= n (pseudo-length pl)))
     180     (if (not (pair? pl))
     181       '()
     182       (let loop ((k 0) (pl pl) (result '()))
     183         (if (= k n)
     184           (reverse result)
     185           (loop (+ k 1) (cdr pl) (cons (car pl) result))))))
     186    ((pl)
     187     (pseudo-head pl (pseudo-length pl)))))
    155188
    156189(define (pseudo-flatten tree)
     
    214247        (pseudo-list? xpr)
    215248        "is xpr a pseudo-list?"
    216         "returns always #t")
     249        "i.e. not a list?")
     250    (pseudo-list-of
     251      procedure:
     252      (pseudo-list-of . preds)
     253      "returns a unary predicate, which checks"
     254      "if its argument passes each predicate in preds")
    217255    (pseudo-null?
    218256      procedure:
     
    237275      procedure:
    238276        (pseudo-tail pl n)
     277        (pseudo-tail pl)
    239278        "returns the tail of pl starting with index n, where n is"
    240         "less than or equal to pl's pseudo-length")
     279        "less than or equal to pl's pseudo-length,"
     280        "if n is not provided, pl's pseudo-length is assumed")
    241281    (pseudo-head
    242282      procedure:
    243283        (pseudo-head pl n)
     284        (pseudo-head pl)
    244285        "returns the head of pl up to but excluding index n,"
    245         "where n is less than or equal to pl's pseudo-length")
     286        "where n is less than or equal to pl's pseudo-length;"
     287        "if n is not provided, pl's pseudo-length is assumed")
    246288    (pseudo-flatten
    247289      procedure:
  • release/4/basic-macros/trunk/basic-macros.setup

    r34873 r35031  
    1010   "basic-macros.import.so"
    1111   "basic-macro-helpers.import.so")
    12  '((version "1.2")))
     12 '((version "1.3")))
  • release/4/basic-macros/trunk/tests/run.scm

    r34857 r35031  
    3737  (check
    3838    (pseudo-list? "x")
     39    (pseudo-list? '(a b . c))
     40    (not (pseudo-list? '()))
     41    (not (pseudo-list? '(a b c)))
    3942    (pseudo-null? 5)
     43    ((pseudo-list-of) "x")
     44    ((pseudo-list-of symbol?) '(a b . c))
    4045    (equal? (pseudo-list #f 1 2 3 4)
    4146            '(1 2 3 4 . #f))
     
    4651    (equal? (pseudo-head '(0 . 1) 0) '())
    4752    (equal? (pseudo-head '(0 . 1) 1) '(0))
     53    (equal? (pseudo-head '(0 . 1)) '(0))
     54    (= (pseudo-tail '(0 . 1)) 1)
    4855    (not (condition-case (pseudo-ref 1 0)
    4956           ((exn) #f)))
Note: See TracChangeset for help on using the changeset viewer.