stk/Lib/init.stk

569 lines
17 KiB
Plaintext

;;;;
;;;; i n i t . s t k -- The file launched at startup
;;;;
;;;; Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;; $Id: init.stk 1.13 Fri, 10 Apr 1998 09:13:18 +0200 eg $
;;;;
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
;;;; Creation date: ??-Sep-1993 ??:??
;;;; Last file update: 8-Apr-1998 11:41
;;;;
;;;==============================================================================
;;;
;;; 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=? (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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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->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))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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)))
(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 ":")
'())))
(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 (os-kind)
(case (machine-type)
(("MS_Win32") 'Windows)
(else 'Unix)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; 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 STk
;; Make the STklos autoload symbols accessible from the global scope
(import STklos)
;; Define some useful autoload
(autoload "unix" 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 called for prompting the user
(define (repl-display-prompt 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)))
;; Procedure called for printing toplevel evals
(define (repl-display-result result)
(unless (eqv? result (make-undefined))
(call-with-values (lambda () result)
(lambda l
(for-each (lambda (x) (write* x) (newline)) l))))))