stk/Lib/init.stk

;;;;
;;;; i n i t . s t k			-- The file launched at startup
;;;;
;;;; Copyright <20> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;;    Creation date: ??-Sep-1993 ??:??
;;;; Last file update: 14-Sep-1999 21:50 (eg)
;;;;

;;;==============================================================================
;;;
;;; Define some global variables (i.e. in the STk module)
;;; 
;;;==============================================================================

(with-module STk
  (import Scheme)
  (define *print-banner*   #t)	     ; #f to avoid the Copyright message
  (define *debug*    	   #f)	     ; #t for debuggging (disable macro inlining)
  (define *argc* 	   (length *argv*))
  (define Tk:initialized?  #f)
  (define *shared-suffix* (cond 
			   ((string=? (machine-type) "Ms-Win32") "dll")
			   ((string=? (substring (machine-type) 0 2) "HP") "sl")
			   (else      "so")))
  (define *load-suffixes*  (list "stk" "stklos" "scm" *shared-suffix*))
  (define *load-path*	   #f)
  (define *load-verbose*   #f))

;;;==============================================================================
;;;
;;; The following code is in the Scheme module (since this file is loaded in the 
;;; Scheme module)
;;; 
;;;==============================================================================

(define call-with-current-continuation			;; The R5RS one
  (let ((call/cc call-with-current-continuation))	;; The R4RS one
    (lambda (proc)
      (call/cc (lambda (cont)
		 (proc (lambda l (cont (apply values l)))))))))

(define call/cc call-with-current-continuation)		;; To make life easier

(define !		 system)

(define (os-kind)
  (if (string=? (machine-type) "Ms-Win32")
      'Windows
      'Unix))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Some stuff for defining macros
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define define-macro #f)
(define %replace     #f)
(define %beginify    #f)

(let ((if if) (and and) (begin begin) (set-car! set-car!) (set-cdr! set-cdr!)
      (not not) (pair? pair?) (car car) (cdr cdr) 
      (null? null?) (cons cons) 
      (let let) (macro macro) (list list) (append append))

  (set! %replace
	(lambda (before after)
	  (if (and (not *debug*) (pair? before) (pair? after))
	      (begin
		(set-car! before (car after))
		(set-cdr! before (cdr after))))
	  after))

  (set! %beginify 
	(lambda (forms)
	  (if (null? (cdr forms)) (car forms) (cons 'begin forms))))

  (set! define-macro 
	(macro form
	  (let ((name (car (car (cdr form))))
		(args (cdr (car (cdr form)))))
	    (list 'define name
		  (list 'macro 'params
			(list '%replace 
			      'params
			      (list 'apply
				    (append (list 'lambda args)
					    (cdr (cdr form)))
				    (list 'cdr 'params)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Some utilities
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define gensym 
  (let ((counter 0))
    (lambda prefix
      (set! counter (+ counter 1))
      (string->uninterned-symbol
         (string-append (if (null? prefix) "G" (car prefix))
			(number->string counter))))))

(define (apropos s)
  (if (not (symbol? s)) (error "apropos: bad symbol" s))
  (let ((res '())
	(env (the-environment))
	(str (symbol->string s)))

    (do ((l (cdr (environment->list env)) (cdr l))); cdr to avoid the binding to "s"
	((null? l) (if (null? res) #f (list->set res)))
      (do ((v (car l) (cdr v)))
	  ((null? v))
	(if (and (string-find? str (symbol->string (caar v))) 
		 (symbol-bound? (caar v)))
	    (set! res (cons (caar v) res)))))))

(define (documentation x)
  "provides documentation for its parameter if it exists"
  (define (nodoc)
    (format #t "No documentation available for ~A\n" x))
  (cond
    ((closure? x) (let ((body (procedure-body x)))
		    (if (string? (caddr body)) 
			(format #t "~A\n" (caddr body))
			(nodoc))))))

(define make-unbound 
  (let ((unbound (make-vector 1)))
    (lambda ()
      (vector-ref unbound 0))))

(define unbound?
  (let ((unbound (make-unbound)))
    (lambda (o)
      (eq? o unbound))))

(define (make-undefined)
  (if #f #t))

(define (undefined? o)
  (eq? o (if #f #t)))

(define-macro (define-variable var value)  ;; The Elisp/CL defvar
  `(with-module STk
	(unless  (symbol-bound? ',var) (define ,var ,value))))

(define-macro (receive vars producer . body)
  `(call-with-values (lambda () ,producer)
		     (lambda ,vars ,@body)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Random 
;;;;	This version of random is constructed over the C one. It can return
;;;;	bignum numbers. Idea is due to Nobuyuki Hikichi <hikichi@sra.co.jp>
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define random 
  (let ((C-random random)
	(max-rand #x7fffffff)) ; Probably more on 64 bits machines
    (letrec ((rand (lambda (n)
		     (cond 
		      ((zero? n)	   0)
		      ((< n max-rand) (C-random n))
		      (else 	  (+ (* (rand (quotient n max-rand)) max-rand)
				     (rand (remainder n max-rand))))))))
      (lambda (n)
	(if (zero? n)
	    (error "random: bad number: 0")
	    (rand n))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; do
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-macro (do inits test . body)
  (let ((loop-name (gensym)))
    `(letrec ((,loop-name 
	       (lambda ,(map car inits)
		 (if ,(car test)
		     (begin ,@(if (null? (cdr test)) 
				  (list (make-undefined))
				  (cdr test)))
		     (begin ,@body
			    (,loop-name ,@(map (lambda (init)
						 (if (null? (cddr init))
						     (car init)
						     (caddr init)))
					       inits)))))))
       (,loop-name ,@(map cadr inits)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; dotimes
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-macro (dotimes binding . body)
  (if (list? binding)
      ;; binding is a list
      (let ((var   #f) (count #f) (result #f))
	(case (length binding)
	  (2  (set! var    (car binding))
	      (set! count  (cadr binding))
	      (set! result (make-undefined)))
	  (3  (set! var    (car binding))
	      (set! count  (cadr binding))
	      (set! result (caddr binding)))
	  (else (error "dotimes: bad binding construct: ~S" binding)))
	`(do ((,var 0 (+ ,var 1)))
	     ((>= ,var ,count) ,result)
	   ,@body))
      ;; binding is ill-formed
      (error "dotimes: binding is not a list: ~S" binding)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; case
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-macro (case key . clauses)
  ;; conditionally execute the clause eqv? to key
  (define (case-make-clauses key)
    `(cond ,@(map
              (lambda (clause)
                (if (pair? clause)
                    (let ((case (car clause))
                          (exprs (cdr clause)))
                      (cond ((eq? case 'else)
                             `(else ,@exprs))
                            ((pair? case)
                             (if (= (length case) 1)
                                 `((eqv? ,key ',(car case)) ,@exprs)
                                 `((memv ,key ',case) ,@exprs)))
                            (else
                             `((eqv? ,key ',case) ,@exprs))))
                    (error "case: invalid syntax in ~a" clause)))
              clauses)))
  (if (pair? key)
      (let ((newkey (gensym)))
        `(let ((,newkey ,key))
           ,(case-make-clauses newkey)))
      (case-make-clauses key)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; fluid-let
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-macro (fluid-let bindings . body)
  (let* ((vars (map car bindings))
	 (vals (map cadr bindings))
	 (tmps (map (lambda (x) (gensym)) vars)))
    `(let ,(map list tmps vars)
       (dynamic-wind
	  (lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars vals))
	  (lambda () ,@body)
	  (lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars tmps))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Some usal macros 
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-macro (unquote form) 
  (error "Usage of unquote outside of quasiquote in ,~A" form))

(define-macro (unquote-splicing form) 
  (error "Usage of unquote-splicing outside of quasiquote in ,@~A" form))

(define 1+ (macro form (list + (cadr form) 1)))
(define 1- (macro form (list - (cadr form) 1)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Section 6.10
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (call-with-input-file string proc)
  (let* ((file   (open-input-file string))
	 (result (proc file)))
    (close-input-port file)
    result))

(define (call-with-output-file string proc)
  (let* ((file   (open-output-file string))
	 (result (proc file)))
    (close-output-port file)
    result))


(define (call-with-input-string string proc)
  (proc (open-input-string string)))

(define (call-with-output-string proc)
  (let ((str (open-output-string)))
    (proc str)
    (get-output-string str)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; File management
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (build-path-from-shell-variable var)
  (let ((path (getenv var)))	
    (if path 
	(split-string path (if (eqv? (os-kind) 'Unix) ":" ";"))
	'())))

(let ((lib  (%library-location)))
  ;; If user has specified a load path with STK_LOAD_PATH, use it
  ;; Always append STK_LIBRARY at end to be sure to find our files  
  (set! *load-path* (append (list ".")
			    (build-path-from-shell-variable "STK_LOAD_PATH")
			    (list (expand-file-name
				        (string-append lib "/../site-scheme"))
				  (string-append lib "/STk")
				  (string-append lib "/" (machine-type))))))

;;;
;;; Require/Provide/Provided?
;;;

(define require   #f)   ; This is a little bit tricky here: variables are
(define provide   #f)	; defined in the Scheme module, but their associated
(define provided? #f)	; closure is in the STk module. In this way, the
			; LOAD done in the REQUIRE procedure is done in the
			; global namespace, which is what is desired for REQUIRE.

(with-module STk
   (let ((provided '()))

     (set! require   (lambda (what)
		       (unless (member what provided)
			 (load what (current-module))
			 (unless (member what provided)
			   (format #t "WARNING: ~S was not provided~%" what)))
		       what))

     (set! provide   (lambda (what)
		       (unless (member what provided)
			 (set! provided (cons what provided)))
		       what))
     
     (set! provided? (lambda (what)
		       (and (member what provided) #t)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Port conversions
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (port->string p)
  (unless (or (input-port? p) (input-string-port? p))
     (error "port->string: Bad port ~S" p))
  (let loop ((res '()))
    (let ((line (read-line p)))
      (if (eof-object? line)
          (apply string-append (reverse res))
	  (loop (cons "\n" (cons line res)))))))

(define (port->list reader p)
  (unless (or (input-port? p) (input-string-port? p))
     (error "port->list: Bad port ~S" p))
  ;; Read all the lines of port and put them in a list
  (let loop ((res '()) (sexp (reader p)))
    (if (eof-object? sexp) 
	(reverse res)
	(loop (cons sexp res) (reader p)))))
 
(define (port->sexp-list p) 
  (port->list read p))

(define (port->string-list p)
  (port->list read-line p))

(define (exec command)
  (call-with-input-file (string-append "| " command) port->string))

(define (exec-string-list command)
  (call-with-input-file (string-append "| " command) port->string-list))
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Misc
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (closure? obj)
  (and (procedure? obj) (procedure-body obj) #t))

(define (primitive? obj)
  (and (procedure? obj) (not (procedure-body obj)) #t))

(define (widget? obj)
  (and (tk-command? obj) (not (catch (obj 'configure)))))


(define (& . l)
  (let loop ((l l) (res ""))
    (if (null? l)
        res
        (let ((e (car l)))
          (loop (cdr l) 
		(string-append res 
			       (cond 
				  ((string? e) e)
				  ((symbol? e) (symbol->string e))
				  ((widget? e) (widget->string e))
				  ((number? e) (number->string e))
				  (ELSE	       (format #f "~S" e)))))))))

(define-macro (unwind-protect body . unwind-forms)
  `(dynamic-wind
    (lambda () #f)
    (lambda () ,body)
    (lambda () ,@unwind-forms)))

(define-macro (when test . body)
  `(if ,test ,@(if (= (length body) 1) body `((begin ,@body)))))

(define-macro (unless test . body)
  `(if (not ,test) ,@(if (= (length body) 1) body `((begin ,@body)))))

(define-macro (multiple-value-bind vars form . body)
  `(apply (lambda ,vars ,@body) ,form))

(define (map* fn . l) 		; A map which accepts dotted lists (arg lists  
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (cons (apply fn      (map car l))
			  (apply map* fn (map cdr l))))
   (else            (apply fn l))))

(define (for-each* fn . l) 	; A for-each which accepts dotted lists (arg lists  
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
   (else            (apply fn l))))

(define (some pred l)
  (if (null? l) 
      #f
      (or (pred (car l)) 
	  (some pred (cdr l)))))

(define (every pred l)
  (if (null? l)
      #t
      (and (pred (car l) )
	   (every pred (cdr l)))))


;; Tell if the parameter string is a complete (or a set of complete) sexpr
(define (complete-sexpr? s) 
  (with-input-from-string s
    (lambda ()
      (let Loop ()
	(let ((sexpr #f))
	  (if (catch (set! sexpr (read)))
	      #f
	      (or (eof-object? sexpr) (Loop))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 
;;;; Set functions
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list->set l)
  (letrec ((rem-dupl (lambda (l res)
		       (cond
			((null? l) 	     res)
			((memv (car l) res) (rem-dupl (cdr l) res))
			(ELSE		    (rem-dupl (cdr l) (cons (car l) 
								    res)))))))
    (rem-dupl l '())))

(define (set-union l1 l2)
  (list->set (append l1 l2)))

(define (set-intersection l1 l2)
  (cond ((null? l1) 	     l1)
	((null? l2) 	     l2)
	((memv (car l1) l2)  (cons (car l1) (set-intersection (cdr l1) l2)))
	(else 		     (set-intersection (cdr l1) l2))))

(define (set-difference l1 l2)
  (cond ((null? l1) 	     l1)
	((memv (car l1) l2)  (set-difference (cdr l1) l2))
	(else 		     (cons (car l1) (set-difference (cdr l1) l2)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Module stuff
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-macro (export . l)
  `(begin
     ,@(map (lambda (x)
	      (let ((x (if (and (pair? x) (eq? (car x) 'setter))
			   (extended-name->scheme-name x)
			   x)))
		`(export-symbol ',x (current-module))))
	    l)
     ,(make-undefined)))
  

(define ~ with-module)

#| FIXME: Probably more harmful than useful. Delete it?

(define-macro (duplicate-module-exports from to . prefix)
  (let* ((prefix  (if (null? prefix) "" (symbol->string (car prefix))))
	 (exports (module-exports (find-module from)))
	 (symbols (map (lambda (x) 
			 (string->symbol (string-append prefix (symbol->string x))))
		       exports)))
    `(with-module ,to
	,@(map (lambda (x y) 
		 `(define ,x (with-module ,from ,y)))
	       symbols exports))))
|#

;;;
;;; quit and bye procedures. Since Tk redefine exit, they cannot be simple aliases
;;;
(define quit (lambda l (apply exit l)))
(define bye  (lambda l (apply exit l)))

;;;==============================================================================
;;;
;;; Code for STklos autoloading 
;;;
;;;==============================================================================

(define-module STklos
  (import Scheme)
  (export  define-class define-method define-generic describe make method)

  (autoload "stklos" 	define-class define-method define-generic make method)
  (autoload "describe"	describe))


;;;==============================================================================
;;;
;;; Finish initializations
;;;
;;;==============================================================================

(with-module Scheme
  (autoload "defsyntax" define-syntax)   
  ;; SRFIs
  (autoload "srfi-0"	cond-expand)
  (autoload "srfi-2"	land*)
  (autoload "srfi-7"	program))




(with-module STk
  ;; Make the STklos autoload symbols accessible from the global scope
  (import STklos)

  ;; Define some useful autoload
  (autoload "fs" 	basename dirname decompose-file-name)
  (autoload "process"	run-process process?)
  (autoload "regexp"	string->regexp regexp? regexp-replace regexp-replace-all)
  (autoload "trace" 	trace untrace)
  (autoload "hash"   	make-hash-table hash-table-hash)
  (autoload "socket"   	make-server-socket make-client-socket)
  (autoload "match"	match-case match-lambda)
  (autoload "ffi"	define-external external-exists?)
  (autoload "extset"	setter extended-name->scheme-name)
  (autoload "pp"    	pp) ;; martine pretty-print package 



  ;; Procedure used for writing the components of toplevel result. This
  ;; is far from perfect, but this is sufficient for the most obvious
  ;; cases (shared sublists, which are not circular structures, typically 
  ;; for n-queens problems ...)
  (define repl-write (lambda (x) ((if (list? x) write write*) x)))

  ;; Procedure called for prompting the user
  (define (repl-display-prompt module)
    (let ((RDP (lambda (module)
		 (let ((p (current-error-port))
		       (n (module-name module)))
		   (flush)	; flush *stdout* before printing the prompt
		   (format p "~A> " (case n
				      ((stk)    "STk")
				      ((stklos) "STklos")
				      ((scheme) "Scheme")
				      ((tk)	   "Tk")
				      (else	  n)))
		   (flush p)))))
      ;; RDP is the real prompt procedure. The body of this function is
      ;; only executed for the displaying the first prompt
      (when Tk:initialized?
	;; This autoload was in tk-init but it causes problems when an
	;; error occur in the file loaded before the first prompt
	;; appears. Now, we use the graphical report error only when
	;; everything is correctly initialized. 
	(tk-set-error-handler!)) ; make STk:report-error and bgerror autoload

      (set! repl-display-prompt RDP)
      (repl-display-prompt module)))
  
  ;; Procedure called for printing toplevel results
  (define (repl-display-result result)
    (if (eqv? result (make-undefined))
	(when *last-defined*
	  (format #t "~S\n" *last-defined*)
	  (set! *last-defined* #f))
	(call-with-values (lambda () result)
			  (lambda l
			    (for-each (lambda (x) (repl-write x) (newline)) l))))))