* Scmutils in guile-2.0 @ 2013-02-07 20:46 Mikael Djurfeldt 2013-02-07 22:00 ` Ludovic Courtès 0 siblings, 1 reply; 3+ messages in thread From: Mikael Djurfeldt @ 2013-02-07 20:46 UTC (permalink / raw) To: guile-user, guile-devel, Gabriel Schnoering [-- Attachment #1: Type: text/plain, Size: 359 bytes --] As an exercise before porting the up-to-date version of scmutils, I eventually decided to bring Daniel Gildea's Guile port up-to-date. You'll find the archive guile-scmutils-v0.8.tgz here: http://www.cs.rochester.edu/~gildea/guile-scmutils/ You should be able to apply the attached patch and then be able to run it under guile-2.0 Best regards, Mikael D. [-- Attachment #2: guile-scmutils-v0.8-2.0.diff --] [-- Type: application/octet-stream, Size: 13300 bytes --] diff -ur guile-scmutils/src/calculus/interior-product.scm guile-scmutils-2.0/src/calculus/interior-product.scm --- guile-scmutils/src/calculus/interior-product.scm 2006-11-04 21:20:27.000000000 +0100 +++ guile-scmutils-2.0/src/calculus/interior-product.scm 2013-02-07 11:31:16.368287479 +0100 @@ -24,19 +24,20 @@ ;|# (define (interior-product X) - (assert (vector-field? X) "X not a vector field: interior-product") (define (ix alpha) (assert (form-field? alpha) "alpha not a form field: interior-product") (let ((p (get-rank alpha))) - (assert (> p 0) "Rank of form not greater than zero: interior-product") (define (the-product . args) (assert (= (length args) (- p 1)) "Wrong number of arguments to interior product") (apply alpha (cons X args))) + (assert (> p 0) "Rank of form not greater than zero: interior-product") (procedure->nform-field the-product `((interior-product ,(diffop-name X)) ,(diffop-name alpha)) (- p 1)))) + (assert (vector-field? X) "X not a vector field: interior-product") + ix) \f ;#| diff -ur guile-scmutils/src/calculus/manifold.scm guile-scmutils-2.0/src/calculus/manifold.scm --- guile-scmutils/src/calculus/manifold.scm 2006-11-04 21:20:27.000000000 +0100 +++ guile-scmutils-2.0/src/calculus/manifold.scm 2013-02-07 11:28:55.658414853 +0100 @@ -87,10 +87,6 @@ (lambda (point) (s:map/r simplify-numerical-expression point))))) - (if (and (not (fix:= n (manifold 'dimension))) - (not (eq? coordinate-system-name 'embedding))) - (error "Coordinate system does not have dimension of manifold" - coordinate-system-name (manifold 'manifold-name))) (define (the-coordinate-system m) (case m ((manifold) manifold) @@ -178,6 +174,11 @@ (else (error "Unknown message: coordinate-system" coordinate-system-name (manifold 'manifold-name))))))) + (if (and (not (fix:= n (manifold 'dimension))) + (not (eq? coordinate-system-name 'embedding))) + (error "Coordinate system does not have dimension of manifold" + coordinate-system-name (manifold 'manifold-name))) + ((manifold 'new-coordinates) the-coordinate-system))) (list coordinate-system-name (manifold 'name))) diff -ur guile-scmutils/src/calculus/speedup.scm guile-scmutils-2.0/src/calculus/speedup.scm --- guile-scmutils/src/calculus/speedup.scm 2006-11-04 22:50:58.000000000 +0100 +++ guile-scmutils-2.0/src/calculus/speedup.scm 2013-02-07 11:32:59.005663142 +0100 @@ -276,7 +276,6 @@ (assert (tensor-field? g) "Not a tensor field.") (let ((type (tensor-type g))) (let ((u (car type)) (d (cdr type))) - (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric") (define ((the-inverted-metric w1 w2) m) (let* ((coeffs ((tensor-field->coefficient-structure g coordinate-system) m)) @@ -292,6 +291,7 @@ ((tensor-manifold g) 'point-prototype)) m))) + (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric") (make-tensor-field d u the-inverted-metric `(invert ,(diffop-name g)) diff -ur guile-scmutils/src/calculus/tensor.scm guile-scmutils-2.0/src/calculus/tensor.scm --- guile-scmutils/src/calculus/tensor.scm 2006-11-04 21:20:28.000000000 +0100 +++ guile-scmutils-2.0/src/calculus/tensor.scm 2013-02-07 11:32:11.057020636 +0100 @@ -263,7 +263,6 @@ "Metric tensor and the coordinate system must have the same manifold.") (let ((type (tensor-type g))) (let ((u (car type)) (d (cdr type))) - (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric") (define ((the-inverted-metric w1 w2) m) (let ((coeffs ((tensor-field->coefficient-structure g coordinate-system) m))) @@ -271,6 +270,7 @@ (((coefficient-structure->tensor-field icoeffs coordinate-system) w1 w2) m)))) + (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric") (make-tensor-field d u the-inverted-metric `(invert ,(diffop-name g)) diff -ur guile-scmutils/src/compat.scm guile-scmutils-2.0/src/compat.scm --- guile-scmutils/src/compat.scm 2009-04-13 15:37:51.000000000 +0200 +++ guile-scmutils-2.0/src/compat.scm 2013-02-07 21:20:23.630473932 +0100 @@ -26,6 +26,8 @@ ; guile (define* (proc (#:optional arg)) ... ; (lambda* (proc (#:optional arg)) ... ;;;;; +(cond-expand (guile-2 + (use-modules (ice-9 curried-definitions)))) (use-modules (ice-9 optargs)) (define (default-object? x) (eq? #f x)) @@ -67,8 +69,12 @@ ;(require 'fluid-let) ; deprecated ; ignore integrable -(define define-integrable define) - +(cond-expand (guile-2 + (define-syntax define-integrable + (syntax-rules () + ((_ form body ...) (define form body ...))))) + (else + (define define-integrable define))) @@ -115,12 +121,15 @@ ; guile 1.6 does not have numerator/denominator ; but guile 1.8 does -(if (not (defined? 'numerator)) - (define (numerator x) x)) -(if (not (defined? 'denominator)) - (define (denominator x) 1)) -(if (not (defined? 'rationalize)) - (define (rationalize x err) x)) +(cond-expand (guile-2 + ) + (else + (if (not (defined? 'numerator)) + (define (numerator x) x)) + (if (not (defined? 'denominator)) + (define (denominator x) 1)) + (if (not (defined? 'rationalize)) + (define (rationalize x err) x)))) (define fix:fixnum? number?) @@ -171,8 +180,8 @@ (define string->uninterned-symbol gensym) (use-modules (ice-9 pretty-print)) -(define pp pretty-print) - +(define* (pp object #:optional (output-port (current-output-port)) (as-code #f)) + (pretty-print object output-port)) (define (guarantee-exact-positive-integer x msg) (if (not (exact-positive-integer? x)) @@ -182,10 +191,16 @@ (if (not (symbol? x)) (error msg x "not a symbol"))) +(define guile-procedure-arity + (if (defined? 'procedure-minimum-arity) + procedure-minimum-arity + (lambda (proc) + (or (assoc-ref (procedure-properties proc) 'apply-hook-arity) + (assoc-ref (procedure-properties proc) 'arity))))) + (define (procedure-arity proc) ; if apply hook, use arity of underlying procedure - (let ((arity (or (assoc-ref (procedure-properties proc) 'apply-hook-arity) - (assoc-ref (procedure-properties proc) 'arity)))) + (let ((arity (guile-procedure-arity proc))) ; convert from guile arity: (min opt more-possible) ; to mit arity: (min . max) max is #f if more-possible (cons (car arity) @@ -256,8 +271,11 @@ (define (make-initialized-vector n proc) (list->vector (make-initialized-list n proc))) -(if (not (defined? 'vector-copy)) - (define (vector-copy v) (list->vector (vector->list v)))) +(cond-expand (guile-2 + ) + (else + (if (not (defined? 'vector-copy)) + (define (vector-copy v) (list->vector (vector->list v)))))) (define (find-matching-item l pred) (if (null? l) diff -ur guile-scmutils/src/general/memoize.scm guile-scmutils-2.0/src/general/memoize.scm --- guile-scmutils/src/general/memoize.scm 2006-11-05 00:31:23.000000000 +0100 +++ guile-scmutils-2.0/src/general/memoize.scm 2013-01-25 15:17:18.877332138 +0100 @@ -278,7 +278,7 @@ ;;; are ALWAYS unprotected, so we cannot use a weak table here. (define (hash-memoize f) - (let ((table) (memo-hits) (memo-misses)) + (let ((table #f) (memo-hits #f) (memo-misses #f)) (let ((info (lambda () (list memo-hits memo-misses table))) @@ -327,7 +327,7 @@ (let ((arity (procedure-arity proc))) (let ((memoized-procedure (cond ((equal? arity '(0 . 0)) - (let ((ran? #f) (value)) + (let ((ran? #f) (value #f)) (lambda () (if ran? value diff -ur guile-scmutils/src/load-real.scm guile-scmutils-2.0/src/load-real.scm --- guile-scmutils/src/load-real.scm 2007-05-15 02:33:49.000000000 +0200 +++ guile-scmutils-2.0/src/load-real.scm 2013-02-07 21:30:06.746070636 +0100 @@ -29,9 +29,12 @@ ;(add-subsystem-identification! "\n ScmUtils" '("Mechanics " " Fall 2006")) -(if (defined? 'scmutils-base-environment) - (set-current-module scmutils-base-environment) - (define scmutils-base-environment (current-module))) +(define scmutils-base-environment + (if (defined? 'scmutils-base-environment) + (begin + (set-current-module scmutils-base-environment) + scmutils-base-environment) + (current-module))) ;(load "general/comutils.scm"); scmutils-base-environment) diff -ur guile-scmutils/src/numerics/linear/svd.scm guile-scmutils-2.0/src/numerics/linear/svd.scm --- guile-scmutils/src/numerics/linear/svd.scm 2006-11-05 13:50:07.000000000 +0100 +++ guile-scmutils-2.0/src/numerics/linear/svd.scm 2013-02-07 11:27:30.557298175 +0100 @@ -123,12 +123,12 @@ (let* ((m (num-rows a)) (n (num-cols a)) ;;(nm (max n m)) (ierr 0) - (g) (scale) (anorm) - (l) (f) (h) (s) - (its) (flag1) (flag2) (l1) (c) (flag3) (k1) - (convergence) - (x) (y) (z) - (i) + (g #f) (scale #f) (anorm #f) + (l #f) (f #f) (h #f) (s #f) + (its #f) (flag1 #f) (flag2 #f) (l1 #f) (c #f) (flag3 #f) (k1 #f) + (convergence #f) + (x #f) (y #f) (z #f) + (i #f) (*svd.a* (array-copy a)) (*svd.u* (array-copy a)) diff -ur guile-scmutils/src/primes.scm guile-scmutils-2.0/src/primes.scm --- guile-scmutils/src/primes.scm 2009-04-13 15:34:59.000000000 +0200 +++ guile-scmutils-2.0/src/primes.scm 2013-01-25 15:02:31.308498819 +0100 @@ -94,7 +94,10 @@ (or (null? lst) (and (= 1 (gcd n (car lst))) (mapf (cdr lst))))))) (define prime:prime-sqr 121) (define prime:products '(105)) -(define prime:sieve (list->uniform-vector #\nul '(0 0 1 1 0 1 0 1 0 0 0))) +(define prime:sieve #f) +(if (defined? 'list->s8vector) + (set! prime:sieve (list->s8vector '(0 0 1 1 0 1 0 1 0 0 0))) + (set! prime:sieve (list->uniform-vector #\nul '(0 0 1 1 0 1 0 1 0 0 0)))) (letrec ((lp (lambda (comp comps primes nexp) (cond ((< comp (quotient most-positive-fixnum nexp)) (let ((ncomp (* nexp comp))) diff -ur guile-scmutils/src/simplify/matcher.scm guile-scmutils-2.0/src/simplify/matcher.scm --- guile-scmutils/src/simplify/matcher.scm 2006-11-01 02:43:34.000000000 +0100 +++ guile-scmutils-2.0/src/simplify/matcher.scm 2013-02-07 11:24:47.319155328 +0100 @@ -130,7 +130,6 @@ list-match) \f (define* (match:reverse-segment variable #:optional submatch) - (if (default-object? submatch) (set! submatch match:equal)) (define (reverse-segment-match data dictionary succeed) (if (list? data) (let ((vcell (match:lookup variable dictionary))) @@ -154,6 +153,7 @@ (else #f)))))) #f)) #f)) + (if (default-object? submatch) (set! submatch match:equal)) reverse-segment-match) (define (datum=? datum1 datum2) diff -ur guile-scmutils/src/srfi-40.scm guile-scmutils-2.0/src/srfi-40.scm --- guile-scmutils/src/srfi-40.scm 2007-02-17 22:16:59.000000000 +0100 +++ guile-scmutils-2.0/src/srfi-40.scm 2013-02-07 11:20:19.499573179 +0100 @@ -1,6 +1,23 @@ (use-modules (srfi srfi-9)) ; provides define-recored-type (use-modules (ice-9 syncase)) ; provides define-syntax +;;; STREAM -- LIBRARY OF SYNTAX AND FUNCTIONS TO MANIPULATE STREAMS + +;;; A stream is a new data type, disjoint from all other data types, that +;;; contains a promise that, when forced, is either nil (a single object +;;; distinguishable from all other objects) or consists of an object +;;; (the stream element) followed by a stream. Each stream element is +;;; evaluated exactly once, when it is first retrieved (not when it is +;;; created); once evaluated its value is saved to be returned by +;;; subsequent retrievals without being evaluated again. + +;; STREAM-TYPE -- type of streams +;; STREAM? object -- #t if object is a stream, #f otherwise +(define-record-type stream-type + (make-stream promise) + stream? + (promise stream-promise)) + ;;; PROMISES A LA SRFI-45: ;;; A separate implementation is necessary to @@ -41,23 +58,6 @@ (srfi-40:force promise)))))) -;;; STREAM -- LIBRARY OF SYNTAX AND FUNCTIONS TO MANIPULATE STREAMS - -;;; A stream is a new data type, disjoint from all other data types, that -;;; contains a promise that, when forced, is either nil (a single object -;;; distinguishable from all other objects) or consists of an object -;;; (the stream element) followed by a stream. Each stream element is -;;; evaluated exactly once, when it is first retrieved (not when it is -;;; created); once evaluated its value is saved to be returned by -;;; subsequent retrievals without being evaluated again. - -;; STREAM-TYPE -- type of streams -;; STREAM? object -- #t if object is a stream, #f otherwise -(define-record-type stream-type - (make-stream promise) - stream? - (promise stream-promise)) - ;;; UTILITY FUNCTIONS ;; STREAM-ERROR message -- print message then abort execution diff -ur guile-scmutils/src/units/SI-units.scm guile-scmutils-2.0/src/units/SI-units.scm --- guile-scmutils/src/units/SI-units.scm 2007-02-17 22:18:14.000000000 +0100 +++ guile-scmutils-2.0/src/units/SI-units.scm 2013-02-07 21:34:45.061695052 +0100 @@ -24,7 +24,8 @@ ;|# ;;;; SI units -(set-current-module generic-environment) +(eval-when (compile load eval) + (set-current-module generic-environment)) (define-unit-system 'SI (list 'meter "m" "length") ^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: Scmutils in guile-2.0 2013-02-07 20:46 Scmutils in guile-2.0 Mikael Djurfeldt @ 2013-02-07 22:00 ` Ludovic Courtès [not found] ` <CAA2XvwLrbhEwGL=MaP9+-9TS2=brpAwdj6C5EwPEoSujmK6JJQ@mail.gmail.com> 0 siblings, 1 reply; 3+ messages in thread From: Ludovic Courtès @ 2013-02-07 22:00 UTC (permalink / raw) To: guile-devel; +Cc: guile-user Hi Mikael, Mikael Djurfeldt <mikael@djurfeldt.com> skribis: > You'll find the archive guile-scmutils-v0.8.tgz here: > > http://www.cs.rochester.edu/~gildea/guile-scmutils/ > > You should be able to apply the attached patch and then be able to run > it under guile-2.0 Nice! > +(cond-expand (guile-2 > + (define-syntax define-integrable > + (syntax-rules () > + ((_ form body ...) (define form body ...))))) You can actually use ‘define-inlinable’ here (info "(guile) Inlinable Procedures"). Ludo’. ^ permalink raw reply [flat|nested] 3+ messages in thread
[parent not found: <CAA2XvwLrbhEwGL=MaP9+-9TS2=brpAwdj6C5EwPEoSujmK6JJQ@mail.gmail.com>]
[parent not found: <87k3qj166m.fsf@gnu.org>]
[parent not found: <CAA2XvwKU6GyJWs9nTDy=UFyrZuPQ5OHriRxfJ=taUuxcY477FA@mail.gmail.com>]
[parent not found: <87y5ezyt9p.fsf@gnu.org>]
* Re: Scmutils in guile-2.0 [not found] ` <87y5ezyt9p.fsf@gnu.org> @ 2013-02-13 22:10 ` Mikael Djurfeldt 0 siblings, 0 replies; 3+ messages in thread From: Mikael Djurfeldt @ 2013-02-13 22:10 UTC (permalink / raw) To: guile-user, guile-devel [-- Attachment #1: Type: text/plain, Size: 126 bytes --] Daniel Gildea reported problems for guile-2.0 guile-scmutils. Those are fixed in the attached diff. Best regards, Mikael D. [-- Attachment #2: guile-scmutils-v0.8-2.0-2.diff --] [-- Type: application/octet-stream, Size: 14245 bytes --] diff -ur guile-scmutils/src/calculus/interior-product.scm guile-scmutils-2.0/src/calculus/interior-product.scm --- guile-scmutils/src/calculus/interior-product.scm 2006-11-04 21:20:27.000000000 +0100 +++ guile-scmutils-2.0/src/calculus/interior-product.scm 2013-02-07 11:31:16.368287479 +0100 @@ -24,19 +24,20 @@ ;|# (define (interior-product X) - (assert (vector-field? X) "X not a vector field: interior-product") (define (ix alpha) (assert (form-field? alpha) "alpha not a form field: interior-product") (let ((p (get-rank alpha))) - (assert (> p 0) "Rank of form not greater than zero: interior-product") (define (the-product . args) (assert (= (length args) (- p 1)) "Wrong number of arguments to interior product") (apply alpha (cons X args))) + (assert (> p 0) "Rank of form not greater than zero: interior-product") (procedure->nform-field the-product `((interior-product ,(diffop-name X)) ,(diffop-name alpha)) (- p 1)))) + (assert (vector-field? X) "X not a vector field: interior-product") + ix) \f ;#| diff -ur guile-scmutils/src/calculus/manifold.scm guile-scmutils-2.0/src/calculus/manifold.scm --- guile-scmutils/src/calculus/manifold.scm 2006-11-04 21:20:27.000000000 +0100 +++ guile-scmutils-2.0/src/calculus/manifold.scm 2013-02-07 11:28:55.658414853 +0100 @@ -87,10 +87,6 @@ (lambda (point) (s:map/r simplify-numerical-expression point))))) - (if (and (not (fix:= n (manifold 'dimension))) - (not (eq? coordinate-system-name 'embedding))) - (error "Coordinate system does not have dimension of manifold" - coordinate-system-name (manifold 'manifold-name))) (define (the-coordinate-system m) (case m ((manifold) manifold) @@ -178,6 +174,11 @@ (else (error "Unknown message: coordinate-system" coordinate-system-name (manifold 'manifold-name))))))) + (if (and (not (fix:= n (manifold 'dimension))) + (not (eq? coordinate-system-name 'embedding))) + (error "Coordinate system does not have dimension of manifold" + coordinate-system-name (manifold 'manifold-name))) + ((manifold 'new-coordinates) the-coordinate-system))) (list coordinate-system-name (manifold 'name))) diff -ur guile-scmutils/src/calculus/speedup.scm guile-scmutils-2.0/src/calculus/speedup.scm --- guile-scmutils/src/calculus/speedup.scm 2006-11-04 22:50:58.000000000 +0100 +++ guile-scmutils-2.0/src/calculus/speedup.scm 2013-02-07 11:32:59.005663142 +0100 @@ -276,7 +276,6 @@ (assert (tensor-field? g) "Not a tensor field.") (let ((type (tensor-type g))) (let ((u (car type)) (d (cdr type))) - (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric") (define ((the-inverted-metric w1 w2) m) (let* ((coeffs ((tensor-field->coefficient-structure g coordinate-system) m)) @@ -292,6 +291,7 @@ ((tensor-manifold g) 'point-prototype)) m))) + (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric") (make-tensor-field d u the-inverted-metric `(invert ,(diffop-name g)) diff -ur guile-scmutils/src/calculus/tensor.scm guile-scmutils-2.0/src/calculus/tensor.scm --- guile-scmutils/src/calculus/tensor.scm 2006-11-04 21:20:28.000000000 +0100 +++ guile-scmutils-2.0/src/calculus/tensor.scm 2013-02-07 11:32:11.057020636 +0100 @@ -263,7 +263,6 @@ "Metric tensor and the coordinate system must have the same manifold.") (let ((type (tensor-type g))) (let ((u (car type)) (d (cdr type))) - (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric") (define ((the-inverted-metric w1 w2) m) (let ((coeffs ((tensor-field->coefficient-structure g coordinate-system) m))) @@ -271,6 +270,7 @@ (((coefficient-structure->tensor-field icoeffs coordinate-system) w1 w2) m)))) + (assert (and (fix:= u 0) (fix:= d 2)) "Not a 2-down metric") (make-tensor-field d u the-inverted-metric `(invert ,(diffop-name g)) diff -ur guile-scmutils/src/compat.scm guile-scmutils-2.0/src/compat.scm --- guile-scmutils/src/compat.scm 2009-04-13 15:37:51.000000000 +0200 +++ guile-scmutils-2.0/src/compat.scm 2013-02-13 23:06:07.815695350 +0100 @@ -26,6 +26,8 @@ ; guile (define* (proc (#:optional arg)) ... ; (lambda* (proc (#:optional arg)) ... ;;;;; +(cond-expand (guile-2 + (use-modules (ice-9 curried-definitions)))) (use-modules (ice-9 optargs)) (define (default-object? x) (eq? #f x)) @@ -67,8 +69,12 @@ ;(require 'fluid-let) ; deprecated ; ignore integrable -(define define-integrable define) - +(cond-expand (guile-2 + (define-syntax define-integrable + (syntax-rules () + ((_ form body ...) (define-inlinable form body ...))))) + (else + (define define-integrable define))) @@ -115,12 +121,15 @@ ; guile 1.6 does not have numerator/denominator ; but guile 1.8 does -(if (not (defined? 'numerator)) - (define (numerator x) x)) -(if (not (defined? 'denominator)) - (define (denominator x) 1)) -(if (not (defined? 'rationalize)) - (define (rationalize x err) x)) +(cond-expand (guile-2 + ) + (else + (if (not (defined? 'numerator)) + (define (numerator x) x)) + (if (not (defined? 'denominator)) + (define (denominator x) 1)) + (if (not (defined? 'rationalize)) + (define (rationalize x err) x)))) (define fix:fixnum? number?) @@ -171,8 +180,8 @@ (define string->uninterned-symbol gensym) (use-modules (ice-9 pretty-print)) -(define pp pretty-print) - +(define* (pp object #:optional (output-port (current-output-port)) (as-code #f)) + (pretty-print object output-port)) (define (guarantee-exact-positive-integer x msg) (if (not (exact-positive-integer? x)) @@ -182,10 +191,16 @@ (if (not (symbol? x)) (error msg x "not a symbol"))) +(define guile-procedure-arity + (if (defined? 'procedure-minimum-arity) + procedure-minimum-arity + (lambda (proc) + (assoc-ref (procedure-properties proc) 'arity)))) + (define (procedure-arity proc) ; if apply hook, use arity of underlying procedure - (let ((arity (or (assoc-ref (procedure-properties proc) 'apply-hook-arity) - (assoc-ref (procedure-properties proc) 'arity)))) + (let ((arity (or (procedure-property proc 'apply-hook-arity) + (guile-procedure-arity proc)))) ; convert from guile arity: (min opt more-possible) ; to mit arity: (min . max) max is #f if more-possible (cons (car arity) @@ -220,9 +235,10 @@ (set-apply-proc (set! proc (caddr args))) (else (apply proc args))))) + (set-procedure-property! aph 'apply-hook? #t) (if proc (set-procedure-property! aph 'apply-hook-arity - (assoc-ref (procedure-properties proc) 'arity))) + (guile-procedure-arity proc))) aph) ; implementation of mit scheme apply-hook feature @@ -235,14 +251,11 @@ (aph #:set-apply-proc #t proc) (if proc (set-procedure-property! aph 'apply-hook-arity - (assoc-ref (procedure-properties proc) 'arity)))) + (guile-procedure-arity proc)))) (define (apply-hook? proc) -(and (procedure? proc) - (assoc-ref (procedure-properties proc) 'arglist) - (eq? (caaddr (assoc-ref (procedure-properties proc) 'arglist)) - 'get-apply-extra))) + (and (procedure? proc) (procedure-property proc 'apply-hook?))) ;;;;; some list routines that are part of mit scheme @@ -256,8 +269,11 @@ (define (make-initialized-vector n proc) (list->vector (make-initialized-list n proc))) -(if (not (defined? 'vector-copy)) - (define (vector-copy v) (list->vector (vector->list v)))) +(cond-expand (guile-2 + ) + (else + (if (not (defined? 'vector-copy)) + (define (vector-copy v) (list->vector (vector->list v)))))) (define (find-matching-item l pred) (if (null? l) diff -ur guile-scmutils/src/general/memoize.scm guile-scmutils-2.0/src/general/memoize.scm --- guile-scmutils/src/general/memoize.scm 2006-11-05 00:31:23.000000000 +0100 +++ guile-scmutils-2.0/src/general/memoize.scm 2013-01-25 15:17:18.877332138 +0100 @@ -278,7 +278,7 @@ ;;; are ALWAYS unprotected, so we cannot use a weak table here. (define (hash-memoize f) - (let ((table) (memo-hits) (memo-misses)) + (let ((table #f) (memo-hits #f) (memo-misses #f)) (let ((info (lambda () (list memo-hits memo-misses table))) @@ -327,7 +327,7 @@ (let ((arity (procedure-arity proc))) (let ((memoized-procedure (cond ((equal? arity '(0 . 0)) - (let ((ran? #f) (value)) + (let ((ran? #f) (value #f)) (lambda () (if ran? value diff -ur guile-scmutils/src/load-real.scm guile-scmutils-2.0/src/load-real.scm --- guile-scmutils/src/load-real.scm 2007-05-15 02:33:49.000000000 +0200 +++ guile-scmutils-2.0/src/load-real.scm 2013-02-07 21:30:06.746070636 +0100 @@ -29,9 +29,12 @@ ;(add-subsystem-identification! "\n ScmUtils" '("Mechanics " " Fall 2006")) -(if (defined? 'scmutils-base-environment) - (set-current-module scmutils-base-environment) - (define scmutils-base-environment (current-module))) +(define scmutils-base-environment + (if (defined? 'scmutils-base-environment) + (begin + (set-current-module scmutils-base-environment) + scmutils-base-environment) + (current-module))) ;(load "general/comutils.scm"); scmutils-base-environment) diff -ur guile-scmutils/src/numerics/linear/svd.scm guile-scmutils-2.0/src/numerics/linear/svd.scm --- guile-scmutils/src/numerics/linear/svd.scm 2006-11-05 13:50:07.000000000 +0100 +++ guile-scmutils-2.0/src/numerics/linear/svd.scm 2013-02-07 11:27:30.557298175 +0100 @@ -123,12 +123,12 @@ (let* ((m (num-rows a)) (n (num-cols a)) ;;(nm (max n m)) (ierr 0) - (g) (scale) (anorm) - (l) (f) (h) (s) - (its) (flag1) (flag2) (l1) (c) (flag3) (k1) - (convergence) - (x) (y) (z) - (i) + (g #f) (scale #f) (anorm #f) + (l #f) (f #f) (h #f) (s #f) + (its #f) (flag1 #f) (flag2 #f) (l1 #f) (c #f) (flag3 #f) (k1 #f) + (convergence #f) + (x #f) (y #f) (z #f) + (i #f) (*svd.a* (array-copy a)) (*svd.u* (array-copy a)) diff -ur guile-scmutils/src/primes.scm guile-scmutils-2.0/src/primes.scm --- guile-scmutils/src/primes.scm 2009-04-13 15:34:59.000000000 +0200 +++ guile-scmutils-2.0/src/primes.scm 2013-01-25 15:02:31.308498819 +0100 @@ -94,7 +94,10 @@ (or (null? lst) (and (= 1 (gcd n (car lst))) (mapf (cdr lst))))))) (define prime:prime-sqr 121) (define prime:products '(105)) -(define prime:sieve (list->uniform-vector #\nul '(0 0 1 1 0 1 0 1 0 0 0))) +(define prime:sieve #f) +(if (defined? 'list->s8vector) + (set! prime:sieve (list->s8vector '(0 0 1 1 0 1 0 1 0 0 0))) + (set! prime:sieve (list->uniform-vector #\nul '(0 0 1 1 0 1 0 1 0 0 0)))) (letrec ((lp (lambda (comp comps primes nexp) (cond ((< comp (quotient most-positive-fixnum nexp)) (let ((ncomp (* nexp comp))) diff -ur guile-scmutils/src/simplify/matcher.scm guile-scmutils-2.0/src/simplify/matcher.scm --- guile-scmutils/src/simplify/matcher.scm 2006-11-01 02:43:34.000000000 +0100 +++ guile-scmutils-2.0/src/simplify/matcher.scm 2013-02-07 11:24:47.319155328 +0100 @@ -130,7 +130,6 @@ list-match) \f (define* (match:reverse-segment variable #:optional submatch) - (if (default-object? submatch) (set! submatch match:equal)) (define (reverse-segment-match data dictionary succeed) (if (list? data) (let ((vcell (match:lookup variable dictionary))) @@ -154,6 +153,7 @@ (else #f)))))) #f)) #f)) + (if (default-object? submatch) (set! submatch match:equal)) reverse-segment-match) (define (datum=? datum1 datum2) diff -ur guile-scmutils/src/srfi-40.scm guile-scmutils-2.0/src/srfi-40.scm --- guile-scmutils/src/srfi-40.scm 2007-02-17 22:16:59.000000000 +0100 +++ guile-scmutils-2.0/src/srfi-40.scm 2013-02-07 11:20:19.499573179 +0100 @@ -1,6 +1,23 @@ (use-modules (srfi srfi-9)) ; provides define-recored-type (use-modules (ice-9 syncase)) ; provides define-syntax +;;; STREAM -- LIBRARY OF SYNTAX AND FUNCTIONS TO MANIPULATE STREAMS + +;;; A stream is a new data type, disjoint from all other data types, that +;;; contains a promise that, when forced, is either nil (a single object +;;; distinguishable from all other objects) or consists of an object +;;; (the stream element) followed by a stream. Each stream element is +;;; evaluated exactly once, when it is first retrieved (not when it is +;;; created); once evaluated its value is saved to be returned by +;;; subsequent retrievals without being evaluated again. + +;; STREAM-TYPE -- type of streams +;; STREAM? object -- #t if object is a stream, #f otherwise +(define-record-type stream-type + (make-stream promise) + stream? + (promise stream-promise)) + ;;; PROMISES A LA SRFI-45: ;;; A separate implementation is necessary to @@ -41,23 +58,6 @@ (srfi-40:force promise)))))) -;;; STREAM -- LIBRARY OF SYNTAX AND FUNCTIONS TO MANIPULATE STREAMS - -;;; A stream is a new data type, disjoint from all other data types, that -;;; contains a promise that, when forced, is either nil (a single object -;;; distinguishable from all other objects) or consists of an object -;;; (the stream element) followed by a stream. Each stream element is -;;; evaluated exactly once, when it is first retrieved (not when it is -;;; created); once evaluated its value is saved to be returned by -;;; subsequent retrievals without being evaluated again. - -;; STREAM-TYPE -- type of streams -;; STREAM? object -- #t if object is a stream, #f otherwise -(define-record-type stream-type - (make-stream promise) - stream? - (promise stream-promise)) - ;;; UTILITY FUNCTIONS ;; STREAM-ERROR message -- print message then abort execution diff -ur guile-scmutils/src/units/SI-units.scm guile-scmutils-2.0/src/units/SI-units.scm --- guile-scmutils/src/units/SI-units.scm 2007-02-17 22:18:14.000000000 +0100 +++ guile-scmutils-2.0/src/units/SI-units.scm 2013-02-07 21:34:45.061695052 +0100 @@ -24,7 +24,8 @@ ;|# ;;;; SI units -(set-current-module generic-environment) +(eval-when (compile load eval) + (set-current-module generic-environment)) (define-unit-system 'SI (list 'meter "m" "length") ^ permalink raw reply [flat|nested] 3+ messages in thread
end of thread, other threads:[~2013-02-13 22:10 UTC | newest] Thread overview: 3+ messages (download: mbox.gz follow: Atom feed -- links below jump to the message on this page -- 2013-02-07 20:46 Scmutils in guile-2.0 Mikael Djurfeldt 2013-02-07 22:00 ` Ludovic Courtès [not found] ` <CAA2XvwLrbhEwGL=MaP9+-9TS2=brpAwdj6C5EwPEoSujmK6JJQ@mail.gmail.com> [not found] ` <87k3qj166m.fsf@gnu.org> [not found] ` <CAA2XvwKU6GyJWs9nTDy=UFyrZuPQ5OHriRxfJ=taUuxcY477FA@mail.gmail.com> [not found] ` <87y5ezyt9p.fsf@gnu.org> 2013-02-13 22:10 ` Mikael Djurfeldt
This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).