summaryrefslogtreecommitdiff
path: root/src/stklos/lib.stk
diff options
context:
space:
mode:
Diffstat (limited to 'src/stklos/lib.stk')
-rw-r--r--src/stklos/lib.stk317
1 files changed, 317 insertions, 0 deletions
diff --git a/src/stklos/lib.stk b/src/stklos/lib.stk
new file mode 100644
index 0000000..3c3b9f0
--- /dev/null
+++ b/src/stklos/lib.stk
@@ -0,0 +1,317 @@
+;;;;
+;;;; 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)))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-01 04:24:38 +0000