From 89a424521b753ee7c2c67ebdc957865657f647c4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Mon, 31 Oct 2005 16:16:54 +0000 Subject: Moved the STkLos and Bigloo code to `legacy'. Moved the STkLos and Bigloo code from `src' to `legacy'. git-archimport-id: lcourtes@laas.fr--2005-mobile/skribilo--devel--1.2--patch-9 --- legacy/stklos/lib.stk | 317 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 317 insertions(+) create mode 100644 legacy/stklos/lib.stk (limited to 'legacy/stklos/lib.stk') diff --git a/legacy/stklos/lib.stk b/legacy/stklos/lib.stk new file mode 100644 index 0000000..3c3b9f0 --- /dev/null +++ b/legacy/stklos/lib.stk @@ -0,0 +1,317 @@ +;;;; +;;;; lib.stk -- Utilities +;;;; +;;;; Copyright © 2003-2004 Erick Gallesio - I3S-CNRS/ESSI +;;;; +;;;; +;;;; 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))) -- cgit v1.2.3