From f4c4d31c649a3afda7f2bdc49763e3f2940477bf Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Wed, 24 Apr 2013 11:26:14 -0700
Subject: [PATCH] planetarium: Cool it with the integration and other
declarations.
Internal (declare)s are still used, but top-level declarations
(usual-integrations) and (integrate-external) are already made by
compile-file, so are just another barrier to portabimini.
Procedures like project and make-x-rotation-matrix need not be inlined
as they already use flo:vectors to pass 2, 3 and 9 flonums around
efficiently. Not inlining these reduces matrices.scm to zero
integrable definitions (no .ext file)!
---
src/gtk/gtk.pkg | 1 +
src/planetarium/compile.scm | 7 ++++---
src/planetarium/earth.scm | 5 +----
src/planetarium/geometry.scm | 6 ++----
src/planetarium/matrices.scm | 14 +++++++-------
src/planetarium/mit-scheme-graphics.scm | 2 --
src/planetarium/mit-scheme-x.scm | 2 --
src/planetarium/mit-scheme.scm | 19 ++++++++-----------
src/planetarium/solar.scm | 3 +--
src/planetarium/tellurion.scm | 3 ---
src/planetarium/time.scm | 2 --
11 files changed, 24 insertions(+), 40 deletions(-)
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 57a5d06d1..007183d0c 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -418,6 +418,7 @@ USA.
gtk-graphics/draw-text
gtk-graphics/draw-circle
gtk-graphics/fill-polygon-list
+ gtk-graphics/clear
gtk-graphics/flush
gtk-graphics/make))
diff --git a/src/planetarium/compile.scm b/src/planetarium/compile.scm
index c3c0c17fc..a60dee726 100644
--- a/src/planetarium/compile.scm
+++ b/src/planetarium/compile.scm
@@ -25,6 +25,7 @@ USA.
(compile-system "planetarium" (directory-pathname (current-load-pathname))
'dependencies
`(("solar" "geometry")
- ("earth" "geometry" "matrices")
- ("mit-scheme-cil" "earth" ,@(directory-read "cil-*.txt"))
- ("tellurion" "geometry" "matrices")))
\ No newline at end of file
+ ("earth" "geometry")
+ ("mit-scheme-cil"
+ "mit-scheme-syntax" ,@(directory-read "cil-*.txt"))
+ ("tellurion" "geometry")))
\ No newline at end of file
diff --git a/src/planetarium/earth.scm b/src/planetarium/earth.scm
index e058cea2c..7b2185909 100644
--- a/src/planetarium/earth.scm
+++ b/src/planetarium/earth.scm
@@ -24,9 +24,6 @@ USA.
;;; Much of this is stolen from Arthur's WorldMap.java, which he
;;; mistakenly lent me.
-(declare (usual-integrations)
- (integrate-external "geometry" "matrices"))
-
(define (draw-earth device orientation solar-lat/long)
(let ((solar-orientation
(let ((Mx (make-x-rotation-matrix
@@ -92,7 +89,7 @@ USA.
(draw-segment device start end color))
(loop (flo:+ i 1.) end)))))
-(define-integrable-operator (project latitude longitude orientation)
+(define (project latitude longitude orientation)
(let ((point (make-3d-point
(flo:* (flo:cos latitude) (flo:sin longitude))
(flo:sin latitude)
diff --git a/src/planetarium/geometry.scm b/src/planetarium/geometry.scm
index b7cc02a98..fabdf65d2 100644
--- a/src/planetarium/geometry.scm
+++ b/src/planetarium/geometry.scm
@@ -21,8 +21,6 @@ USA.
|#
-(declare (usual-integrations))
-
(define-integrable pi (flo:* 4. (flo:atan2 1. 1.)))
(define-integrable 2pi (flo:* 8. (flo:atan2 1. 1.)))
(define-integrable pi/2 (flo:* 2. (flo:atan2 1. 1.)))
@@ -77,7 +75,7 @@ USA.
":"(string-pad-left (number->string (car min.r)) 2 #\0)
":"(string-pad-left (number->string (cdr min.r)) 2 #\0))))
-(define-integrable-operator (lesser-angle a b)
+(define (lesser-angle a b)
;; Angle B translated to (not more than 2pi) numerically less than A.
(let loop ((b b))
(cond ((flo:< b (flo:- a 2pi))
@@ -87,7 +85,7 @@ USA.
(else
(loop (flo:- b 2pi))))))
-(define-integrable-operator (greater-angle a b)
+(define (greater-angle a b)
;; Angle B translated to (not more than 2pi) numerically greater than A.
(let loop ((b b))
(cond ((flo:< a (flo:- b 2pi))
diff --git a/src/planetarium/matrices.scm b/src/planetarium/matrices.scm
index e598983bd..fa38e983e 100644
--- a/src/planetarium/matrices.scm
+++ b/src/planetarium/matrices.scm
@@ -21,9 +21,9 @@ USA.
|#
-(declare (usual-integrations) (no-type-checks) (no-range-checks))
+(declare (no-type-checks) (no-range-checks))
-(define-integrable-operator (3d-transform! point transform projection)
+(define (3d-transform! point transform projection)
;; point X transform => projection The projection may be eq point.
(define-integrable (t i j)
(flo:vector-ref transform (fix:+ (fix:* i 3) j)))
@@ -38,7 +38,7 @@ USA.
(flo:vector-set! projection 1 (f 1))
(flo:vector-set! projection 2 (f 2))))
-(define-integrable-operator (3d-multiply! A B C)
+(define (3d-multiply! A B C)
;; A X B => C C may be eq A or B.
(define-integrable (ref m row col)
(flo:vector-ref m (fix:+ (fix:* (fix:-1+ row) 3) (fix:-1+ col))))
@@ -64,12 +64,12 @@ USA.
(flo:vector-set! C 7 (f+ (f* A31 B12) (f* A32 B22) (f* A33 B32)))
(flo:vector-set! C 8 (f+ (f* A31 B13) (f* A32 B23) (f* A33 B33)))))
-(define-integrable (make-3d-identity-matrix)
+(define (make-3d-identity-matrix)
(flo:3d-matrix 1. 0. 0.
0. 1. 0.
0. 0. 1.))
-(define-integrable-operator (make-x-rotation-matrix radians)
+(define (make-x-rotation-matrix radians)
(let ((cos (flo:cos radians))
(sin (flo:sin radians)))
(let ((-sin (flo:negate sin)))
@@ -77,7 +77,7 @@ USA.
0. cos -sin
0. sin cos))))
-(define-integrable-operator (make-y-rotation-matrix radians)
+(define (make-y-rotation-matrix radians)
(let ((cos (flo:cos radians))
(sin (flo:sin radians)))
(let ((-sin (flo:negate sin)))
@@ -85,7 +85,7 @@ USA.
0. 1. 0.
-sin 0. cos))))
-(define-integrable-operator (make-z-rotation-matrix radians)
+(define (make-z-rotation-matrix radians)
(let ((cos (flo:cos radians))
(sin (flo:sin radians)))
(let ((-sin (flo:negate sin)))
diff --git a/src/planetarium/mit-scheme-graphics.scm b/src/planetarium/mit-scheme-graphics.scm
index 69883f43b..798c8efd3 100644
--- a/src/planetarium/mit-scheme-graphics.scm
+++ b/src/planetarium/mit-scheme-graphics.scm
@@ -23,8 +23,6 @@ USA.
;;;; System specific code for MIT Scheme with simple graphics.
-(declare (usual-integrations))
-
(define (make-suitable-graphics-device)
(let ((device (make-graphics-device)))
(graphics-set-coordinate-limits device -1.1 -1.1 1.1 1.1)
diff --git a/src/planetarium/mit-scheme-x.scm b/src/planetarium/mit-scheme-x.scm
index d7f38788f..de385b8b2 100644
--- a/src/planetarium/mit-scheme-x.scm
+++ b/src/planetarium/mit-scheme-x.scm
@@ -23,8 +23,6 @@ USA.
;;;; System specific code for MIT Scheme with X graphics.
-(declare (usual-integrations))
-
(define (make-suitable-graphics-device)
(let ((device (make-graphics-device 'x)))
(graphics-set-coordinate-limits device -1.1 -1.1 1.1 1.1)
diff --git a/src/planetarium/mit-scheme.scm b/src/planetarium/mit-scheme.scm
index 17d0bc951..d57a495d7 100644
--- a/src/planetarium/mit-scheme.scm
+++ b/src/planetarium/mit-scheme.scm
@@ -30,17 +30,14 @@ USA.
(lambda ()
(let ((env (->environment '(planetarium))))
- (define (compile-load file #!optional dependencies declarations)
+ (define (compile-load file #!optional dependencies)
(let ((deps (if (default-object? dependencies) '() dependencies)))
(fluid-let (;;(compile-file:sf-only? #t)
- (sf/default-declarations
- (if (default-object? declarations)
- '()
- declarations)))
+ (compiler:generate-lap-files? #t))
(compile-file file deps env))
(load file env)))
- (define ignore-errors?
+ (define errors-ignored?
(let ((ok "ok"))
(lambda (thunk)
(let ((v (ignore-errors (lambda () (thunk) ok))))
@@ -50,15 +47,15 @@ USA.
(compile-load "mit-scheme-syntax")
(compile-load "geometry")
- (compile-load "matrices" '() '((no-range-checks)(no-type-checks)))
+ (compile-load "matrices")
(compile-load "time")
(compile-load "solar" '("geometry"))
- (compile-load "earth" '("matrices" "geometry"))
- (compile-load "mit-scheme-cil" (cons "earth"
+ (compile-load "earth" '("geometry"))
+ (compile-load "mit-scheme-cil" (cons "mit-scheme-syntax"
(directory-read "cil-*.txt")))
- (compile-load "tellurion" '("geometry" "matrices"))
+ (compile-load "tellurion" '("geometry"))
(environment-link-name (->environment '()) env 'make-tellurion)
- (cond ((not (ignore-errors? (lambda () (load-option 'gtk))))
+ (cond ((not (errors-ignored? (lambda () (load-option 'gtk))))
(compile-load "mit-scheme-gtk"))
((graphics-type-available? 'x)
(compile-load "mit-scheme-x"))
diff --git a/src/planetarium/solar.scm b/src/planetarium/solar.scm
index 768c0972f..792e46331 100644
--- a/src/planetarium/solar.scm
+++ b/src/planetarium/solar.scm
@@ -25,8 +25,7 @@ USA.
;;; specifically the second English edition (1998) "with corrections
;;; as of August 10, 2009" of _Astronomical_Algorithms_ by Jean Meeus.
-(declare (integrate-external "geometry")
- (reduce-operator (* flo:*)
+(declare (reduce-operator (* flo:*)
(sin flo:sin) (cos flo:cos)
(asin flo:asin) (atan2 flo:atan2)
(- flo:- (null-value 0. single) (group left))
diff --git a/src/planetarium/tellurion.scm b/src/planetarium/tellurion.scm
index f238dea84..f8343e567 100644
--- a/src/planetarium/tellurion.scm
+++ b/src/planetarium/tellurion.scm
@@ -21,9 +21,6 @@ USA.
|#
-(declare (usual-integrations)
- (integrate-external "geometry" "matrices"))
-
(define (make-tellurion)
(test-julian-day)
(test-greenwich-mean-sidereal-time)
diff --git a/src/planetarium/time.scm b/src/planetarium/time.scm
index d5f95ed3e..6cf9129ec 100644
--- a/src/planetarium/time.scm
+++ b/src/planetarium/time.scm
@@ -25,8 +25,6 @@ USA.
;;; specifically the second English edition (1998) "with corrections
;;; as of August 10, 2009" of _Astronomical_Algorithms_ by Jean Meeus.
-(declare (usual-integrations))
-
(define (universal-time->julian-day time)
;; The Julian Ephemeris Day (JDE) corresponding to TIME.
(let ((decoded (universal-time->global-decoded-time time)))
--
2.25.1