From f4c4d31c649a3afda7f2bdc49763e3f2940477bf Mon Sep 17 00:00:00 2001 From: Matt Birkholz 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