path: root/ice-9/misc.scm

(module (ice-9 misc)
	(export in-vicinity with-fluids)
	(open (ice-9 structs) (ice-9 files) (ice-9 defmacro) (ice-9 provide) (ice-9 guile)))



;;; {Simple Debugging Tools}
;;

;; peek takes any number of arguments, writes them to the
;; current ouput port, and returns the last argument.
;; It is handy to wrap around an expression to look at
;; a value each time is evaluated, e.g.:
;;
;;	(+ 10 (troublesome-fn))
;;	=> (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
;;

(define (peek . stuff)
  (newline)
  (display ";;; ")
  (write stuff)
  (newline)
  (car (last-pair stuff)))

(define pk peek)




;;; {Trivial Functions}
;;;

(define (id x) x)
(define (1+ n) (+ n 1))
(define (-1+ n) (+ n -1))
(define 1- -1+)
(define return-it noop)
(define (and=> value procedure) (and value (procedure value)))
(define (make-hash-table k) (make-vector k '()))

;;; apply-to-args is functionally redunant with apply and, worse,
;;; is less general than apply since it only takes two arguments.
;;;
;;; On the other hand, apply-to-args is a syntacticly convenient way to 
;;; perform binding in many circumstances when the "let" family of
;;; of forms don't cut it.  E.g.:
;;;
;;;	(apply-to-args (return-3d-mouse-coords)
;;;	  (lambda (x y z) 
;;;		...))
;;;

(define (apply-to-args args fn) (apply fn args))


;;; {Integer Math}
;;;

(define (ipow-by-squaring x k acc proc)
  (cond ((zero? k) acc)
	((= 1 k) (proc acc x))
	(else (ipow-by-squaring (proc x x)
				(quotient k 2)
				(if (even? k) acc (proc acc x))
				proc))))

(define string-character-length string-length)



;; A convenience function for combining flag bits.  Like logior, but
;; handles the cases of 0 and 1 arguments.
;;
(define (flags . args)
  (cond
   ((null? args) 0)
   ((null? (cdr args)) (car args))
   (else (apply logior args))))


;;; {Multiple return values}

(define *values-rtd*
  (make-record-type "values"
		    '(values)))

(define values
  (let ((make-values (record-constructor *values-rtd*)))
    (lambda x
      (if (and (not (null? x))
	       (null? (cdr x)))
	  (car x)
	  (make-values x)))))

(define call-with-values
  (let ((access-values (record-accessor *values-rtd* 'values))
	(values-predicate? (record-predicate *values-rtd*)))
    (lambda (producer consumer)
      (let ((result (producer)))
	(if (values-predicate? result)
	    (apply consumer (access-values result))
	    (consumer result))))))



;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (map-in-order fn lst) is like (map fn lst) but definately in order of lst.
;;;

;; and-map f l
;;
;; Apply f to successive elements of l until exhaustion or f returns #f.
;; If returning early, return #f.  Otherwise, return the last value returned
;; by f.  If f has never been called because l is empty, return #t.
;; 
(define (and-map f lst)
  (let loop ((result #t)
	     (l lst))
    (and result
	 (or (and (null? l)
		  result)
	     (loop (f (car l)) (cdr l))))))

;; or-map f l
;;
;; Apply f to successive elements of l until exhaustion or while f returns #f.
;; If returning early, return the return value of f.
;;
(define (or-map f lst)
  (let loop ((result #f)
	     (l lst))
    (or result
	(and (not (null? l))
	     (loop (f (car l)) (cdr l))))))


;;; {Booleans}
;;;

(define (->bool x) (not (not x)))


;;; {Load Paths}
;;;

;;; Here for backward compatability
;;
(define scheme-file-suffix (lambda () ".scm"))

(define (in-vicinity vicinity file)
  (let ((tail (let ((len (string-length vicinity)))
		(if (zero? len)
		    #f
		    (string-ref vicinity (- len 1))))))
    (string-append vicinity
		   (if (or (not tail)
			   (eq? tail #\/))
		       ""
		       "/")
		   file)))


;;; {Help for scm_shell}
;;; The argument-processing code used by Guile-based shells generates
;;; Scheme code based on the argument list.  This page contains help
;;; functions for the code it generates.

(define (command-line) (program-arguments))

;; This is mostly for the internal use of the code generated by
;; scm_compile_shell_switches.
(define (load-user-init)
  (define (has-init? dir)
    (let ((path (in-vicinity dir ".guile")))
      (catch 'system-error 
	     (lambda ()
	       (let ((stats (stat path)))
		 (if (not (eq? (stat:type stats) 'directory))
		     path)))
	     (lambda dummy #f))))
  (let ((path (or (has-init? (or (getenv "HOME") "/"))
                  (has-init? (passwd:dir (getpw (getuid)))))))
    (if path (primitive-load path))))



;;; {Reader Extensions}
;;;

;;; Reader code for various "#c" forms.
;;;

;;; Parse the portion of a #/ list that comes after the first slash.
(define (read-path-list-notation slash port)
  (letrec 
      
      ;; Is C a delimiter?
      ((delimiter? (lambda (c) (or (eof-object? c)
				   (char-whitespace? c)
				   (string-index "()\";" c))))

       ;; Read and return one component of a path list.
       (read-component
	(lambda ()
	  (let loop ((reversed-chars '()))
	    (let ((c (peek-char port)))
	      (if (or (delimiter? c)
		      (char=? c #\/))
		  (string->symbol (list->string (reverse reversed-chars)))
		  (loop (cons (read-char port) reversed-chars))))))))

    ;; Read and return a path list.
    (let loop ((reversed-path (list (read-component))))
      (let ((c (peek-char port)))
	(if (and (char? c) (char=? c #\/))
	    (begin
	      (read-char port)
	      (loop (cons (read-component) reversed-path)))
	    (reverse reversed-path))))))

(define (read-path-list-notation-warning slash port)
  (if (not (getenv "GUILE_HUSH"))
      (begin
	(display "warning: obsolete `#/' list notation read from "
		 (current-error-port))
	(display (port-filename port) (current-error-port))
	(display "; see guile-core/NEWS." (current-error-port))
	(newline (current-error-port))
	(display "         Set the GUILE_HUSH environment variable to disable this warning."
		 (current-error-port))
	(newline (current-error-port))))
  (read-hash-extend #\/ read-path-list-notation)
  (read-path-list-notation slash port))


(read-hash-extend #\' (lambda (c port)
			(read port)))
(read-hash-extend #\. (lambda (c port)
			(eval (read port) (the-environment))))

(if (feature? 'array)
    (begin
      (let ((make-array-proc (lambda (template)
			       (lambda (c port)
				 (read:uniform-vector template port)))))
	(for-each (lambda (char template)
		    (read-hash-extend char
				      (make-array-proc template)))
		  '(#\b #\a #\u #\e #\s #\i #\c #\y   #\h)
		  '(#t  #\a 1   -1  1.0 1/3 0+i #\nul s)))
      (let ((array-proc (lambda (c port)
			  (read:array c port))))
	(for-each (lambda (char) (read-hash-extend char array-proc))
		  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))))

;; pushed to the beginning of the alist since it's used more than the
;; others at present.
(read-hash-extend #\/ read-path-list-notation-warning)

(define (read:array digit port)
  (define chr0 (char->integer #\0))
  (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
		(if (char-numeric? (peek-char port))
		    (readnum (+ (* 10 val)
				(- (char->integer (read-char port)) chr0)))
		    val)))
	(prot (if (eq? #\( (peek-char port))
		  '()
		  (let ((c (read-char port)))
		    (case c ((#\b) #t)
			  ((#\a) #\a)
			  ((#\u) 1)
			  ((#\e) -1)
			  ((#\s) 1.0)
			  ((#\i) 1/3)
			  ((#\c) 0+i)
			  (else (error "read:array unknown option " c)))))))
    (if (eq? (peek-char port) #\()
	(list->uniform-array rank prot (read port))
	(error "read:array list not found"))))

(define (read:uniform-vector proto port)
  (if (eq? #\( (peek-char port))
      (list->uniform-array 1 proto (read port))
      (error "read:uniform-vector list not found")))


;;; {IOTA functions: generating lists of numbers}

(define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '()))
(define (iota n) (reverse! (reverse-iota n)))


;;; {While}
;;;
;;; with `continue' and `break'.
;;;

(defmacro while (cond . body)
  `(letrec ((continue (lambda () (or (not ,cond) (begin (begin ,@ body) (continue)))))
	    (break (lambda val (apply throw 'break val))))
     (catch 'break
	    (lambda () (continue))
	    (lambda v (cadr v)))))

;;; {collect}
;;;
;;; Similar to `begin' but returns a list of the results of all constituent
;;; forms instead of the result of the last form.
;;; (The definition relies on the current left-to-right
;;;  order of evaluation of operands in applications.)

(defmacro collect forms
  (cons 'list forms))

;;; {with-fluids}

;; with-fluids is a convenience wrapper for the builtin procedure
;; `with-fluids*'.  The syntax is just like `let':
;;
;;  (with-fluids ((fluid val)
;;                ...)
;;     body)

(defmacro with-fluids (bindings . body)
  `(with-fluids* (list ,@(map car bindings)) (list ,@(map cadr bindings))
		 (lambda () ,@body)))