Changeset 29137 in project


Ignore:
Timestamp:
06/20/13 10:39:36 (8 years ago)
Author:
Ivan Raikov
Message:

unitconv: added dimension checking for derived units and a simple test

Location:
release/4/unitconv/trunk
Files:
1 added
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/unitconv/trunk/unitconv.scm

    r27728 r29137  
    3232         quantity-expr-eval
    3333         unit-factor-eval
     34         unit-factor-dim
    3435
    3536         unitconv:error
     
    4445         unit-name
    4546         unit-factor
     47         unit-dims
    4648         unit-prefix
     49
    4750         unit-convert
    4851         unit/
     
    619622             ((op x . y)
    620623              `(unit-factor-eval ,(binop-fold op (cons x y))))
    621              
     624
    622625             (x         `(cond ((,unit? ,x)   
    623626                                (,unit-factor ,x))
    624627                               ((,number? ,x)  ,x)
    625                                (else  (unitconv:error 'unit-factor-eval ": unknown unit " ,x))))))))
     628                               (else  (unitconv:error 'unit-factor-eval ": unknown unit " ,x))))
     629
     630             (else (error 'unit-factor-eval "invalid unit factor expression" expr)))
     631      )))
    626632         
    627633 
     634
     635(define-syntax unit-factor-dim
     636  (lambda (x r c)
     637    (let ((expr (cadr x))
     638          (%let       (r 'let))
     639          (%cond      (r 'cond))
     640          (%else      (r 'else))
     641          (%print     (r 'print))
     642          (x1         (r 'x1))
     643          (y1         (r 'y1))
     644          (unit?      (r 'unit?))
     645          (unit-dims  (r 'unit-dims))
     646          (quantity-int  (r 'quantity-int))
     647          (number?    (r 'number?)))
     648
     649      (match expr
     650             ((op x y) 
     651              `(,%let ((,x1  (unit-factor-dim ,x))
     652                       (,y1  (unit-factor-dim ,y)))
     653                 ,(case op
     654                    ((*)     `(+ ,x1 ,y1))
     655                    ((/)     `(- ,x1 ,y1))
     656                    (else (unitconv:error 'unit-factor-eval ": unknown unit factor operation " op)))))
     657             
     658             ((op x . y)
     659              `(unit-factor-dim ,(binop-fold op (cons x y))))
     660
     661             (x         `(cond ((,unit? ,x)   
     662                                (,quantity-int (,unit-dims ,x)))
     663                               ((,number? ,x)  0)
     664                               (else  (unitconv:error 'unit-factor-eval ": unknown unit " ,x))))
     665             (else (error 'unit-factor-dim "invalid unit factor expression" expr)))
     666      )))
     667         
    628668
    629669(define-syntax make-unit-prefix
     
    637677(define-syntax define-unit
    638678  (lambda (x r c)
    639     (let ((name (cadr x))
    640           (dims (caddr x))
    641           (factor (cadddr x))
     679    (let ((name    (cadr x))
     680          (dims    (caddr x))
     681          (factor  (cadddr x))
    642682          (abbrevs (cddddr x))
     683          (%factordim  (r 'factordim))
     684          (%if     (r 'if))
    643685          (%define (r 'define))
    644           (%begin (r 'begin)))
    645       `(,%begin
    646         (,%define ,name (make-unit ',name ,dims (unit-factor-eval ,factor) ',abbrevs))
     686          (%let    (r 'let))
     687          (%begin  (r 'begin))
     688          )
     689     
     690      `(,%begin
     691        (,%define ,name (,%let
     692                         ((,%factordim (unit-factor-dim ,factor)))
     693                         (,%if (or (zero? ,%factordim) (= ,%factordim (quantity-int ,dims)))
     694                               (make-unit ',name ,dims (unit-factor-eval ,factor) ',abbrevs)
     695                               (unitconv:error 'define-unit "unit dimension mismatch" ,dims ,%factordim))))
    647696        ,@(map (lambda (abbrev) `(,%define ,abbrev ,name)) abbrevs)))))
    648697
  • release/4/unitconv/trunk/unitconv.setup

    r27728 r29137  
    1313 'unitconv
    1414 `( ,(dynld-name "unitconv") ,(dynld-name "unitconv.import")  )   
    15  `((version 2.3)
     15 `((version 2.4)
    1616   ))
    1717
     
    1919 'with-units
    2020 `( ,(dynld-name "with-units") ,(dynld-name "with-units.import")  )   
    21  `((version 2.3)
     21 `((version 2.4)
    2222   ))
Note: See TracChangeset for help on using the changeset viewer.