path: root/legacy/stklos/lib.stk

;;;;
;;;; lib.stk	-- Utilities
;;;; 
;;;; Copyright � 2003-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
;;;; USA.
;;;; 
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date: 11-Aug-2003 20:29 (eg)
;;;; Last file update: 27-Oct-2004 12:41 (eg)
;;;;

;;;
;;; NEW
;;;
(define (maybe-copy obj)
  (if (pair-mutable? obj)
      obj
      (copy-tree obj)))

(define-macro (new class . parameters)
  `(make ,(string->symbol (format "<~a>" class))
     ,@(apply append (map (lambda (x)
			    `(,(make-keyword (car x)) (maybe-copy ,(cadr x))))
			  parameters))))

;;;
;;; DEFINE-MARKUP
;;;
(define-macro (define-markup bindings . body)
  ;; This is just a STklos extended lambda. Nothing to do
  `(define ,bindings ,@body))


;;;
;;; DEFINE-SIMPLE-MARKUP
;;;
(define-macro (define-simple-markup markup)
  `(define-markup (,markup :rest opts :key ident class loc)
     (new markup
	  (markup ',markup)
	  (ident (or ident (symbol->string (gensym ',markup))))
	  (loc loc)
	  (class class)
	  (required-options '())
	  (options (the-options opts :ident :class :loc))
	  (body (the-body opts)))))


;;;
;;; DEFINE-SIMPLE-CONTAINER
;;;
(define-macro (define-simple-container markup)
   `(define-markup (,markup :rest opts :key ident class loc)
       (new container
	  (markup ',markup)
	  (ident (or ident (symbol->string (gensym ',markup))))
	  (loc loc)
	  (class class)
	  (required-options '())
	  (options (the-options opts :ident :class :loc))
	  (body (the-body opts)))))


;;;
;;; DEFINE-PROCESSOR-MARKUP
;;;
(define-macro (define-processor-markup proc)
  `(define-markup (,proc #!rest opts)
     (new processor
	  (engine  (find-engine ',proc))
	  (body    (the-body opts))
	  (options (the-options opts)))))


;;;
;;; SKRIBE-EVAL-LOCATION ...
;;;
(define (skribe-eval-location)
  (format (current-error-port)
	  "FIXME: ...... SKRIBE-EVAL-LOCATION (should not appear)\n")
  #f)

;;;
;;; SKRIBE-ERROR
;;;
(define (skribe-ast-error proc msg obj)
  (let ((l     (ast-loc obj))
	(shape (if (markup? obj) (markup-markup obj) obj)))
    (if (location? l)
	(error "~a:~a: ~a: ~a ~s" (location-file l) (location-pos l) proc msg shape)
	(error "~a: ~a ~s " proc msg shape))))

(define (skribe-error proc msg obj)
  (if (ast? obj)
      (skribe-ast-error proc msg obj)
      (error proc msg obj)))


;;;
;;; SKRIBE-TYPE-ERROR
;;;
(define (skribe-type-error proc msg obj etype)
  (skribe-error proc (format "~a ~s (~a expected)" msg obj etype) #f))



;;; FIXME: Peut-�tre vir�e maintenant
(define (skribe-line-error file line proc msg obj)
  (error (format "%a:%a:  ~a:~a ~S" file line proc msg obj)))


;;;
;;; SKRIBE-WARNING  &  SKRIBE-WARNING/AST
;;;
(define (%skribe-warn level file line lst)
  (let ((port (current-error-port)))
    (format port "**** WARNING:\n")
    (when (and file line) (format port "~a: ~a: " file line))
    (for-each (lambda (x) (format port "~a " x)) lst)
    (newline port)))


(define (skribe-warning level . obj)
  (if (>= *skribe-warning* level)
      (%skribe-warn level #f #f obj)))


(define (skribe-warning/ast level ast . obj)
  (if (>= *skribe-warning* level)
      (let ((l (ast-loc ast)))
	(if (location? l)
	    (%skribe-warn level (location-file l) (location-pos l) obj)
	    (%skribe-warn level #f #f obj)))))

;;;
;;; SKRIBE-MESSAGE
;;;
(define (skribe-message fmt . obj)
  (when (> *skribe-verbose* 0)
    (apply format (current-error-port) fmt obj)))

;;;
;;; FILE-PREFIX / FILE-SUFFIX
;;; 
(define (file-prefix fn)
  (if fn
      (let ((match (regexp-match "(.*)\\.([^/]*$)" fn)))
	(if match
	    (cadr match)
	    fn))
      "./SKRIBE-OUTPUT"))

(define (file-suffix s)
  ;; Not completely correct, but sufficient here
  (let* ((basename (regexp-replace "^(.*)/(.*)$" s "\\2"))
	 (split    (string-split basename ".")))
    (if (> (length split) 1)
	(car (reverse! split))
	"")))


;;;
;;; KEY-GET
;;;
;;; We need to redefine the standard key-get to be more permissive. In
;;; STklos key-get accepts a list which is formed only of keywords. In
;;; Skribe, parameter lists are of the form
;;;      (:title "..." :option "...." body1 body2 body3)
;;; So is we find an element which is not a keyword, we skip it (unless it
;;; follows a keyword of course). Since the compiler of extended lambda
;;; uses the function key-get, it will now accept Skribe markups
(define (key-get lst key :optional (default #f default?))
  (define (not-found)
    (if default?
	default
	(error 'key-get "value ~S not found in list ~S" key lst)))
  (let Loop ((l lst))
    (cond
      ((null? l)
       (not-found))
      ((not (pair? l))
       (error 'key-get "bad list ~S" lst))
      ((keyword? (car l))
       (if (null? (cdr l))
	   (error 'key-get "bad keyword list ~S" lst)
	   (if (eq? (car l) key)
	       (cadr l)
	       (Loop (cddr l)))))
       (else
	(Loop (cdr l))))))


;;;
;;; UNSPECIFIED?
;;;
(define (unspecified? obj)
  (eq? obj 'unspecified))

;;;; ======================================================================
;;;;
;;;;   				A C C E S S O R S
;;;;
;;;; ======================================================================

;; 							  SKRIBE-PATH
(define (skribe-path) *skribe-path*)

(define (skribe-path-set! path)
  (if (not (and (list? path) (every string? path)))
      (skribe-error 'skribe-path-set! "Illegal path" path)
      (set! *skribe-path* path)))

;; 							  SKRIBE-IMAGE-PATH
(define (skribe-image-path) *skribe-image-path*)

(define (skribe-image-path-set! path)
  (if (not (and (list? path) (every string? path)))
      (skribe-error 'skribe-image-path-set! "Illegal path" path)
      (set! *skribe-image-path* path)))

;; 							  SKRIBE-BIB-PATH
(define (skribe-bib-path) *skribe-bib-path*)

(define (skribe-bib-path-set! path)
  (if (not (and (list? path) (every string? path)))
      (skribe-error 'skribe-bib-path-set! "Illegal path" path)
      (set! *skribe-bib-path* path)))

;; 							  SKRBE-SOURCE-PATH
(define (skribe-source-path) *skribe-source-path*)

(define (skribe-source-path-set! path)
  (if (not (and (list? path) (every string? path)))
      (skribe-error 'skribe-source-path-set! "Illegal path" path)
      (set! *skribe-source-path* path)))

;;;; ======================================================================
;;;;
;;;; 				Compatibility with Bigloo
;;;;
;;;; ======================================================================

(define (substring=? s1 s2 len)
  (let ((l1 (string-length s1))
	(l2 (string-length s2)))
    (let Loop ((i 0))
      (cond
	((= i len) #t)
	((= i l1)  #f)
	((= i l2)  #f)
	((char=? (string-ref s1 i) (string-ref s2 i)) (Loop (+ i 1)))
	(else #f)))))

(define (directory->list str)
  (map basename (glob (string-append str "/*") (string-append "/.*"))))

(define-macro (printf . args)   `(format #t ,@args))
(define fprintf			format)

(define (symbol-append . l)
  (string->symbol (apply string-append (map symbol->string l))))


(define (make-list n . fill)
  (let ((fill (if (null? fill) (void) (car fill))))
    (let Loop ((i n) (res '()))
      (if (zero? i)
	  res
	  (Loop (- i 1) (cons fill res))))))


(define string-capitalize 	string-titlecase)
(define prefix 			file-prefix)
(define suffix 			file-suffix)
(define system->string		exec)
(define any?			any)
(define every?			every)
(define cons* 			list*)
(define find-file/path		find-path)
(define process-input-port	process-input)
(define process-output-port	process-output)
(define process-error-port	process-error)

;;;
;;; h a s h   t a b l e s
;;;
(define make-hashtable		(lambda () (make-hash-table equal?)))
(define hashtable? 		hash-table?)
(define hashtable-get		(lambda (h k) (hash-table-get h k #f)))
(define hashtable-put!		hash-table-put!)
(define hashtable-update!	hash-table-update!)
(define hashtable->list 	(lambda (h)
				  (map cdr (hash-table->list h))))

(define find-runtime-type 	(lambda (obj) obj))

(define-macro (unwind-protect expr1 expr2)
  ;; This is no completely correct. 
  `(dynamic-wind
       (lambda () #f)
       (lambda () ,expr1)
       (lambda () ,expr2)))