Changeset 10968 in project


Ignore:
Timestamp:
06/01/08 01:20:00 (12 years ago)
Author:
Jim Ursetto
Message:

vector-lib: hygienify

Location:
release/4/vector-lib
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/vector-lib/vector-lib.meta

    r9754 r10968  
    55 (category data)
    66 (synopsis
    7    "A port of the reference implementation of SRFI-43 with additions and fixes")
    8  (license "Artistic")
    9  (author
    10    "Taylor Campbell, with CHICKEN-specific modifications by William S. Annis. Adapted to final version and bugs fixed by Zbigniew Szadkowski"))
     7   "Port of the SRFI-43 reference implementation")
     8 (license "BSD")
     9 (author "Taylor Campbell"))
  • release/4/vector-lib/vector-lib.scm

    r7340 r10968  
    77;; These changes were made for Chicken:
    88;; Removed redundant offset checks in VECTOR-COPY and VECTOR-REVERSE-COPY
    9 ;; Removed receive and let-optionals* macros (defined natively in Chicken)
    10 ;; Converted let-vector-start+end from define-syntax to define-macro
     9;; Import receive and let-optionals from Chicken
    1110;; check-type uses native type checking
    1211;; Procedures pass symbol, not procedure object, as callee
     
    4039
    4140(declare
    42  (fixnum)
    43  (not standard-bindings vector-fill! vector->list list->vector)
     41 (fixnum))
     42
     43(cond-expand
     44 (paranoia)
     45 (else
     46  (declare
     47    (no-bound-checks))))
     48
     49(register-feature! 'srfi-43)
    4450
    4551;;; -------- Exported procedure index --------
    46  (export
     52(module vector-lib
     53  (
    4754;;; * Constructors
    4855 ; make-vector                     vector
     
    7582;;; * Conversion
    7683   vector->list                    reverse-vector->list
    77    list->vector                    reverse-list->vector))
    78 
    79 (cond-expand
    80  (paranoia)
    81  (else
    82   (declare
    83     (no-bound-checks))))
    84 
    85 (register-feature! 'srfi-43)
     84   list->vector                    reverse-list->vector)
     85
     86  ;; This jujitsu with the standard bindings lets us avoid multiply-defined
     87  ;; messages and unconditionally overwriting standard bindings at toplevel.
     88  ;; It is subject to change as the Chicken module system evolves.
     89  (import (except scheme list->vector vector->list vector-fill!)
     90          (prefix (only scheme list->vector vector->list vector-fill!)
     91                  %)
     92          (only chicken let-optionals receive))
    8693
    8794;;; Taylor Campbell wrote this code; he places it in the public domain.
     
    163170(cond-expand [unsafe
    164171  (eval-when (compile)
    165     (define-macro (check-type pred? value callee) value)
    166     (define-macro (check-index vec index callee) index)
    167     (define-macro (check-indices vec start start-name end end-name callee) (values start end)))]
     172    (define-inline (check-type pred? value callee) value)
     173    (define-inline (check-index vec index callee) index)
     174    (define-inline (check-indices vec start start-name end end-name callee)
     175      (values start end)))]
    168176
    169177[else
     
    174182;;;   that this happened while calling CALLEE.  Return VALUE if no
    175183;;;   error was signalled.
    176 (define-macro (check-type pred? value callee)
    177   (cond ((eq? pred? 'vector?)     `(begin (##sys#check-vector ,value ,callee) ,value))
    178         ((eq? pred? 'nonneg-int?) `(begin (##sys#check-exact ,value ,callee)
    179                                           (when (fx< ,value 0)
    180                                             (##sys#error ,callee "value is negative" ,value))
    181                                           ,value))
    182         ((eq? pred? 'integer?)    `(begin (##sys#check-exact ,value ,callee) ,value))
    183         ((eq? pred? 'list?)       `(begin (##sys#check-list  ,value ,callee) ,value))
    184         ((eq? pred? 'procedure?)  value)
    185         (else
    186          (##sys#error 'check-type "invalid predicate" pred?))))
     184
     185(import (only chicken when))
     186(define-syntax check-type
     187  (syntax-rules (vector? integer? list? nonneg-int? procedure?)
     188    ((_ vector? value callee)     (begin (##sys#check-vector value callee) value))
     189    ((_ integer? value callee)    (begin (##sys#check-exact value callee) value))
     190    ((_ list? value callee)       (begin (##sys#check-list value callee) value))
     191    ((_ nonneg-int? value callee) (begin (##sys#check-exact value callee)
     192                                         (when (< value 0)
     193                                           (##sys#error callee "value is negative" value))
     194                                         value))
     195    ((_ procedure? value callee)  value)))
    187196
    188197;;; (CHECK-INDEX <vector> <index> <callee>) -> index
     
    298307           (##sys#error callee "too many arguments" (cddr args))))))
    299308
    300 (define-macro (let-vector-start+end callee vec args start+end . body)
    301     (if (or (not (pair? start+end))
    302             (not (null? (cddr start+end))))
    303         (##sys#error 'let-vector-start+end "start+end must be a 2-element list" start+end)
    304         (let ((start (car start+end))
    305               (end (cadr start+end)))
    306           `(let ((,vec (check-type vector? ,vec ',callee)))
    307              (receive (,start ,end)
    308                  (vector-parse-start+end ,vec ,args ',start ',end ',callee)
    309                ,@body)))))
     309(define-syntax let-vector-start+end
     310  (syntax-rules ()
     311    ((let-vector-start+end callee vec args (start end) body1 body2 ...)
     312     (let ((vec (check-type vector? vec callee)))
     313       (receive (start end)
     314                (vector-parse-start+end vec args 'start 'end
     315                                        callee)
     316         body1 body2 ...)))))
    310317
    311318;;; (%SMALLEST-LENGTH <vector-list> <default-length> <callee>)
     
    11031110;;; This one can probably be made really fast natively.
    11041111(define vector-fill!
    1105   (let ((%vector-fill! vector-fill!))   ; Take the native one, under
    1106                                         ;   the assumption that it's
    1107                                         ;   faster, so we can use it if
    1108                                         ;   there are no optional
    1109                                         ;   arguments.
    1110     (lambda (vec value . maybe-start+end)
    1111       (if (null? maybe-start+end)
    1112           (%vector-fill! vec value)     ;+++
    1113           (let-vector-start+end vector-fill! vec maybe-start+end
    1114                                 (start end)
    1115             (do ((i start (+ i 1)))
    1116                 ((= i end))
    1117               (vector-set! vec i value)))))))
     1112  (lambda (vec value . maybe-start+end)
     1113    (if (null? maybe-start+end)
     1114        (%vector-fill! vec value)       ;+++
     1115        (let-vector-start+end vector-fill! vec maybe-start+end
     1116                              (start end)
     1117                              (do ((i start (+ i 1)))
     1118                                  ((= i end))
     1119                                (vector-set! vec i value))))))
    11181120
    11191121;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
     
    11751177;;;   length of VECTOR, from VECTOR.
    11761178(define vector->list
    1177   (let ((%vector->list vector->list))
    1178     (lambda (vec . maybe-start+end)
    1179       (if (null? maybe-start+end)       ; Oughta use CASE-LAMBDA.
    1180           (%vector->list vec)           ;+++
    1181           (let-vector-start+end vector->list vec maybe-start+end
    1182                                 (start end)
    1183             ;(unfold (lambda (i)        ; No SRFI 1.
    1184             ;          (< i start))
    1185             ;        (lambda (i) (vector-ref vec i))
    1186             ;        (lambda (i) (- i 1))
    1187             ;        (- end 1))
    1188             (do ((i (- end 1) (- i 1))
    1189                  (result '() (cons (vector-ref vec i) result)))
    1190                 ((< i start) result)))))))
     1179  (lambda (vec . maybe-start+end)
     1180    (if (null? maybe-start+end)         ; Oughta use CASE-LAMBDA.
     1181        (%vector->list vec)             ;+++
     1182        (let-vector-start+end
     1183         vector->list vec maybe-start+end (start end)
     1184         ;;(unfold (lambda (i)        ; No SRFI 1.
     1185         ;;          (< i start))
     1186         ;;        (lambda (i) (vector-ref vec i))
     1187         ;;        (lambda (i) (- i 1))
     1188         ;;        (- end 1))
     1189         (do ((i (- end 1) (- i 1))
     1190              (result '() (cons (vector-ref vec i) result)))
     1191             ((< i start) result))))))
    11911192
    11921193;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
     
    12191220
    12201221(define list->vector
    1221   (let ((%list->vector list->vector))
    1222     (lambda (lst . maybe-start+end)
    1223       ;; Checking the type of a proper list is expensive, so we do it
    1224       ;; amortizedly, or let %LIST->VECTOR or LIST-TAIL do it.
    1225       (if (null? maybe-start+end)       ; Oughta use CASE-LAMBDA.
    1226           (%list->vector lst)           ;+++
    1227           ;; We can't use LET-VECTOR-START+END, because we're using the
    1228           ;; bounds of a _list_, not a vector.
    1229           (let ((lst (check-type list? lst 'list->vector)))
    1230             (let-optionals maybe-start+end
    1231                 ((start 0)
    1232                  (end (length lst)))      ; Ugh -- LENGTH
    1233               (let ((start (check-type nonneg-int? start 'list->vector))
    1234                     (end   (check-type nonneg-int? end   'list->vector)))
    1235                 ((lambda (f)
    1236                    (vector-unfold f (- end start) (list-tail lst start)))
    1237                  (lambda (index l)
    1238                    (cond ((null? l)
    1239                           (##sys#error 'list->vector "list too short"
    1240                                        `(list ,lst)
    1241                                        `(attempted end ,end)))
    1242                          ((pair? l)
    1243                           (values (car l) (cdr l)))
    1244                          (else
    1245                           (##sys#not-a-proper-list-error lst 'list->vector))))))))))))
     1222  (lambda (lst . maybe-start+end)
     1223    ;; Checking the type of a proper list is expensive, so we do it
     1224    ;; amortizedly, or let %LIST->VECTOR or LIST-TAIL do it.
     1225    (if (null? maybe-start+end)         ; Oughta use CASE-LAMBDA.
     1226        (%list->vector lst)             ;+++
     1227        ;; We can't use LET-VECTOR-START+END, because we're using the
     1228        ;; bounds of a _list_, not a vector.
     1229        (let ((lst (check-type list? lst 'list->vector)))
     1230          (let-optionals maybe-start+end
     1231                         ((start 0)
     1232                          (end (length lst))) ; Ugh -- LENGTH
     1233                         (let ((start (check-type nonneg-int? start 'list->vector))
     1234                               (end   (check-type nonneg-int? end   'list->vector)))
     1235                           ((lambda (f)
     1236                              (vector-unfold f (- end start) (list-tail lst start)))
     1237                            (lambda (index l)
     1238                              (cond ((null? l)
     1239                                     (##sys#error 'list->vector "list too short"
     1240                                                  `(list ,lst)
     1241                                                  `(attempted end ,end)))
     1242                                    ((pair? l)
     1243                                     (values (car l) (cdr l)))
     1244                                    (else
     1245                                     (##sys#not-a-proper-list-error lst 'list->vector)))))))))))
    12461246
    12471247;;; (REVERSE-LIST->VECTOR <list> [<start> <end>]) -> vector
     
    12711271                (values (car l) (cdr l)))
    12721272               (else
    1273                 (##sys#not-a-proper-list-error lst 'reverse-list->vector))))))))
    1274 
     1273                (##sys#not-a-proper-list-error lst 'reverse-list->vector)))))))))
  • release/4/vector-lib/vector-lib.setup

    r7340 r10968  
    1 
    2 (define has-exports? (string>=? (chicken-version) "2.310"))
    3 
    4 (compile -s -O2 -d1
    5         ,@(if has-exports? '(-check-imports -emit-exports vector-lib.exports) '())
    6         vector-lib.scm)
     1(compile -s -O2 -d2 vector-lib.scm)
    72
    83(install-extension 'vector-lib
    94        `("vector-lib.so"
    10                 "vector-lib.html"
    11                 ,@(if has-exports? '("vector-lib.exports") '()) )
     5          "vector-lib.html")
    126        `((version 1.2)
    13                 ,@(if has-exports? `((exports "vector-lib.exports")) '())
    14                 (documentation "vector-lib.html") ) )
     7          (documentation "vector-lib.html") ) )
Note: See TracChangeset for help on using the changeset viewer.