* Scmutils in guile-2.0
@ 2013-02-07 20:46 Mikael Djurfeldt
2013-02-07 22:00 ` Ludovic Courtès
0 siblings, 1 reply; 7+ 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] 7+ 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
2013-02-07 23:33 ` Mikael Djurfeldt
0 siblings, 1 reply; 7+ 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] 7+ messages in thread
* Re: Scmutils in guile-2.0
2013-02-07 22:00 ` Ludovic Courtès
@ 2013-02-07 23:33 ` Mikael Djurfeldt
2013-02-08 9:54 ` Ludovic Courtès
0 siblings, 1 reply; 7+ messages in thread
From: Mikael Djurfeldt @ 2013-02-07 23:33 UTC (permalink / raw
To: Ludovic Courtès; +Cc: guile-devel
On Thu, Feb 7, 2013 at 11:00 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>> +(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").
Sorry, I'm lost.
Doesn't define-inlinable define a procedure?
Here, the idea simply was to have `define-integrable' behave exactly
the same as `define'.
BTW, I provided this patch just so that those who are interested could
get started using guile-scmutils with guile-2.0. However,
guile-scmutils only contains a fraction of the real scmutils. For the
real port, I'm working on an mit-scheme compatibility module so that
as much as possible of the original source can be used as is.
Best regards,
Mikael
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: Scmutils in guile-2.0
2013-02-07 23:33 ` Mikael Djurfeldt
@ 2013-02-08 9:54 ` Ludovic Courtès
2013-02-08 10:07 ` Mikael Djurfeldt
0 siblings, 1 reply; 7+ messages in thread
From: Ludovic Courtès @ 2013-02-08 9:54 UTC (permalink / raw
To: mikael; +Cc: guile-devel
Mikael Djurfeldt <mikael@djurfeldt.com> skribis:
> On Thu, Feb 7, 2013 at 11:00 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>>> +(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").
>
> Sorry, I'm lost.
>
> Doesn't define-inlinable define a procedure?
It does, but it’s equivalent to what some implementations call
‘define-integrable’.
Ludo’.
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: Scmutils in guile-2.0
2013-02-08 9:54 ` Ludovic Courtès
@ 2013-02-08 10:07 ` Mikael Djurfeldt
2013-02-08 10:49 ` Ludovic Courtès
0 siblings, 1 reply; 7+ messages in thread
From: Mikael Djurfeldt @ 2013-02-08 10:07 UTC (permalink / raw
To: Ludovic Courtès; +Cc: guile-devel
On Fri, Feb 8, 2013 at 10:54 AM, Ludovic Courtès <ludo@gnu.org> wrote:
> Mikael Djurfeldt <mikael@djurfeldt.com> skribis:
>
>> On Thu, Feb 7, 2013 at 11:00 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>>>> +(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").
>>
>> Sorry, I'm lost.
>>
>> Doesn't define-inlinable define a procedure?
>
> It does, but it’s equivalent to what some implementations call
> ‘define-integrable’.
Ludovic---sorry, I'm being dense. You see, I just by reflex
interpreted "integrable" as a mathematical term. But I should have
reacted against this being defined as a compatibility measure.
What you are saying is that I should use define-inlinable instead of
define in the definition of define-integrable, right?
I didn't know about the common existence of "define-integrable" in
other implementations! Thanks you!
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: Scmutils in guile-2.0
2013-02-08 10:07 ` Mikael Djurfeldt
@ 2013-02-08 10:49 ` Ludovic Courtès
2013-02-13 22:10 ` Mikael Djurfeldt
0 siblings, 1 reply; 7+ messages in thread
From: Ludovic Courtès @ 2013-02-08 10:49 UTC (permalink / raw
To: mikael; +Cc: guile-devel
Mikael Djurfeldt <mikael@djurfeldt.com> skribis:
> On Fri, Feb 8, 2013 at 10:54 AM, Ludovic Courtès <ludo@gnu.org> wrote:
>> Mikael Djurfeldt <mikael@djurfeldt.com> skribis:
>>
>>> On Thu, Feb 7, 2013 at 11:00 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>>>>> +(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").
>>>
>>> Sorry, I'm lost.
>>>
>>> Doesn't define-inlinable define a procedure?
>>
>> It does, but it’s equivalent to what some implementations call
>> ‘define-integrable’.
>
> Ludovic---sorry, I'm being dense. You see, I just by reflex
> interpreted "integrable" as a mathematical term. But I should have
> reacted against this being defined as a compatibility measure.
>
> What you are saying is that I should use define-inlinable instead of
> define in the definition of define-integrable, right?
Exactly. Sorry for not making myself clear!
Ludo’.
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: Scmutils in guile-2.0
2013-02-08 10:49 ` Ludovic Courtès
@ 2013-02-13 22:10 ` Mikael Djurfeldt
0 siblings, 0 replies; 7+ 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] 7+ messages in thread
end of thread, other threads:[~2013-02-13 22:10 UTC | newest]
Thread overview: 7+ 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
2013-02-07 23:33 ` Mikael Djurfeldt
2013-02-08 9:54 ` Ludovic Courtès
2013-02-08 10:07 ` Mikael Djurfeldt
2013-02-08 10:49 ` Ludovic Courtès
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).