From: Martin M. <ma...@ma...> - 2013-11-08 01:51:20
|
Dear SBCL team. The following code extends LOOP to add a logarithmic iteration path, as in this little example: (loop for i being log from 1 to 10 dec 5 collect i) (0.99999994f0 1.5848931f0 2.5118864f0 3.9810717f0 6.3095737f0 10.000001f0) The code works on the old SMBX Genera and on ACL but does not on SBCL. Can you give me any guidance to why that is, or just point me to a clue - I can try to hack at it but my guess is that the comment in the source namely: ;;;; KLUDGE: In SBCL, we only really use variant (1), and any generality ;;;; for the other variants is wasted. -- WHN 20000121 Suggests this may not be a trivial matter... Martin Mallinson ;; A logarithmic looping function ; i want this: (loop for x being log from 10 to 100 dec 8 ... ; "dec" "oct" "decade" "octave" are all OK and optional, defaults to 10 per-decade, ; to and from must be given. The loop iterations guarantee to cover ; at least the from and to points. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Extend Loop macro to ignore EACH or THE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package "SB-LOOP") (defun loop-for-being (var val data-type) ;; FOR var BEING each/the pathname prep-phrases using-stuff... ;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn. ;; AMM: well it is optional (at least in SMBX) so I fixed it to be so.... (let ((path nil) (data nil) (inclusive nil) (stuff nil) (initial-prepositions nil)) (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) ((loop-tequal (car *loop-source-code*) :and) (loop-pop-source) (setq inclusive t) (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her)) (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax." (car *loop-source-code*))) (loop-pop-source) (setq path (loop-pop-source)) (setq initial-prepositions `((:in ,val)))) ((loop-lookup-keyword val (loop-universe-path-keywords *loop-universe*)) (setq path val)) ;<< MM May 1999 (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?"))) (cond ((not (symbolp path)) (loop-error "~S found where a LOOP iteration path name was expected." path)) ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) (loop-error "~S is not the name of a LOOP iteration path." path)) ((and inclusive (not (loop-path-inclusive-permitted data))) (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) (let ((fun (loop-path-function data)) (preps (nconc initial-prepositions (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t))) (user-data (loop-path-user-data data))) (when (symbolp fun) (setq fun (symbol-function fun))) (setq stuff (if inclusive (apply fun var data-type preps :inclusive t user-data) (apply fun var data-type preps user-data)))) (when *loop-named-variables* (loop-error "Unused USING variables: ~S." *loop-named-variables*)) ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the system from the user ;; and the user from himself. (unless (member (length stuff) '(6 10)) (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." path)) (do ((l (car stuff) (cdr l)) (x)) ((null l)) (if (atom (setq x (car l))) (loop-make-iteration-variable x nil nil) (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) (cddr stuff))) (defun loop-log-path (variable data-type prep-phrases &rest ignore) data-type (flet ((get-it (x) (cadr (assoc x prep-phrases)))) (let ((steps (or (get-it 'dec) (get-it 'per-decade) (get-it 'oct) (get-it 'per-octave) 10)) (base (if (or (get-it 'oct) (get-it 'per-octave)) 2 10)) (bindings nil) (prolog nil) (max-var (gensym)) (down?-var (gensym)) (factor-var (gensym)) (end-test (gensym))) (unless (get-it 'from) (error "LOG Loop iteration requires the FROM keyword in LOOP")) (unless (get-it 'to) (error "LOG Loop iteration requires the TO keyword in LOOP")) (setq prolog `((when (zerop ,variable) (error "Cannot do LOG LOOP macro FROM 0!")) (unless (plusp ,steps) (error "You must have a positive number of steps per ~a in LOG LOOP macro!" (if (= ,base 2) "octave" "decade"))) (when (or (and (plusp ,variable) (not (plusp ,max-var))) (and (not (plusp ,variable)) (plusp ,max-var))) (error "Both the FROM (~a) and TO (~a) must be the same sign in LOG LOOP macro!" ,variable ,max-var)) (setq ,factor-var (if (> (abs ,max-var) (abs ,variable)) (expt ,base (/ ,steps)) (/ (expt ,base (/ ,steps))))) (setq ,end-test (* ,max-var (sqrt ,factor-var))) (setq ,down?-var (< ,max-var ,variable)) (setq ,variable (/ ,(get-it 'from) ,factor-var)))) (setq bindings `((,variable ,(get-it 'from)) (,max-var ,(get-it 'to)) (,down?-var nil) (,end-test nil) (,factor-var nil))) (list bindings prolog `(if ,down?-var (<= ,variable ,end-test) (>= ,variable ,end-test)) `(,variable (* ,variable ,factor-var)) `(if ,down?-var (<= ,variable ,end-test) (>= ,variable ,end-test)) `(,variable ,variable))))) (add-loop-path '(log) #'loop-log-path *loop-universe* :preposition-groups '(from to dec oct per-decade per-octave)) |