;;;;
;;;; i n i t . s t k -- The file launched at startup
;;;;
;;;; Copyright © 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
(if (eqv? (os-kind) 'Windows)
"/site-scheme"
"/../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)))
(define *inhibit-graphical-report-error* #t)
;; 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
(if (not *inhibit-graphical-report-error*)
(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)
(call-with-values (lambda () result)
(lambda l
(for-each (lambda (x) (repl-write x) (newline)) l)))))