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/types.stk | 294 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 294 insertions(+) create mode 100644 legacy/stklos/types.stk (limited to 'legacy/stklos/types.stk') diff --git a/legacy/stklos/types.stk b/legacy/stklos/types.stk new file mode 100644 index 0000000..fb16230 --- /dev/null +++ b/legacy/stklos/types.stk @@ -0,0 +1,294 @@ +;;;; +;;;; types.stk -- Definition of Skribe classes +;;;; +;;;; 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: 12-Aug-2003 22:18 (eg) +;;;; Last file update: 28-Oct-2004 16:18 (eg) +;;;; + + +(define *node-table* (make-hash-table equal?)) + ; Used to stores the nodes of an AST. + ; It permits to retrieve a node from its + ; identifier. + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +;;FIXME: set! location in +(define-class () + ((parent :accessor ast-parent :init-keyword :parent :init-form 'unspecified) + (loc :init-form #f))) + +(define (ast? obj) (is-a? obj )) +(define (ast-loc obj) (slot-ref obj 'loc)) +(define (ast-loc-set! obj v) (slot-set! obj 'loc v)) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((fmt :init-keyword :fmt) + (body :init-keyword :body))) + +(define (command? obj) (is-a? obj )) +(define (command-fmt obj) (slot-ref obj 'fmt)) +(define (command-body obj) (slot-ref obj 'body)) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((proc :init-keyword :proc))) + +(define (unresolved? obj) (is-a? obj )) +(define (unresolved-proc obj) (slot-ref obj 'proc)) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((ast :init-keyword :ast :init-form #f :getter handle-ast))) + +(define (handle? obj) (is-a? obj )) +(define (handle-ast obj) (slot-ref obj 'ast)) + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((required-options :init-keyword :required-options :init-form '()) + (options :init-keyword :options :init-form '()) + (body :init-keyword :body :init-form #f + :getter node-body))) + +(define (node? obj) (is-a? obj )) +(define (node-options obj) (slot-ref obj 'options)) +(define node-loc ast-loc) + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((combinator :init-keyword :combinator :init-form (lambda (e1 e2) e1)) + (engine :init-keyword :engine :init-form 'unspecified) + (procedure :init-keyword :procedure :init-form (lambda (n e) n)))) + +(define (processor? obj) (is-a? obj )) +(define (processor-combinator obj) (slot-ref obj 'combinator)) +(define (processor-engine obj) (slot-ref obj 'engine)) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((ident :init-keyword :ident :getter markup-ident :init-form #f) + (class :init-keyword :class :getter markup-class :init-form #f) + (markup :init-keyword :markup :getter markup-markup))) + + +(define (bind-markup! node) + (hash-table-update! *node-table* + (markup-ident node) + (lambda (cur) (cons node cur)) + (list node))) + + +(define-method initialize ((self ) initargs) + (next-method) + (bind-markup! self)) + + +(define (markup? obj) (is-a? obj )) +(define (markup-options obj) (slot-ref obj 'options)) +(define markup-body node-body) + + +(define (is-markup? obj markup) + (and (is-a? obj ) + (eq? (slot-ref obj 'markup) markup))) + + + +(define (find-markups ident) + (hash-table-get *node-table* ident #f)) + + +(define-method write-object ((obj ) port) + (format port "#[~A (~A/~A) ~A]" + (class-name (class-of obj)) + (slot-ref obj 'markup) + (slot-ref obj 'ident) + (address-of obj))) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((env :init-keyword :env :init-form '()))) + +(define (container? obj) (is-a? obj )) +(define (container-env obj) (slot-ref obj 'env)) +(define container-options markup-options) +(define container-ident markup-ident) +(define container-body node-body) + + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ()) + +(define (document? obj) (is-a? obj )) +(define (document-ident obj) (slot-ref obj 'ident)) +(define (document-body obj) (slot-ref obj 'body)) +(define document-options markup-options) +(define document-env container-env) + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((ident :init-keyword :ident :init-form '???) + (format :init-keyword :format :init-form "raw") + (info :init-keyword :info :init-form '()) + (version :init-keyword :version :init-form 'unspecified) + (delegate :init-keyword :delegate :init-form #f) + (writers :init-keyword :writers :init-form '()) + (filter :init-keyword :filter :init-form #f) + (customs :init-keyword :custom :init-form '()) + (symbol-table :init-keyword :symbol-table :init-form '()))) + + + +(define (engine? obj) + (is-a? obj )) + +(define (engine-ident obj) ;; Define it here since the doc searches it + (slot-ref obj 'ident)) + +(define (engine-format obj) ;; Define it here since the doc searches it + (slot-ref obj 'format)) + +(define (engine-customs obj) ;; Define it here since the doc searches it + (slot-ref obj 'customs)) + +(define (engine-filter obj) ;; Define it here since the doc searches it + (slot-ref obj 'filter)) + +(define (engine-symbol-table obj) ;; Define it here since the doc searches it + (slot-ref obj 'symbol-table)) + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((ident :init-keyword :ident :init-form '??? :getter writer-ident) + (class :init-keyword :class :initform 'unspecified + :getter writer-class) + (pred :init-keyword :pred :init-form 'unspecified) + (upred :init-keyword :upred :init-form 'unspecified) + (options :init-keyword :options :init-form '() :getter writer-options) + (verified? :init-keyword :verified? :init-form #f) + (validate :init-keyword :validate :init-form #f) + (before :init-keyword :before :init-form #f :getter writer-before) + (action :init-keyword :action :init-form #f :getter writer-action) + (after :init-keyword :after :init-form #f :getter writer-after))) + +(define (writer? obj) + (is-a? obj )) + +(define-method write-object ((obj ) port) + (format port "#[~A (~A) ~A]" + (class-name (class-of obj)) + (slot-ref obj 'ident) + (address-of obj))) + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((name :init-keyword :name :init-form #f :getter langage-name) + (fontifier :init-keyword :fontifier :init-form #f :getter langage-fontifier) + (extractor :init-keyword :extractor :init-form #f :getter langage-extractor))) + +(define (language? obj) + (is-a? obj )) + + +;;;; ====================================================================== +;;;; +;;;; +;;;; +;;;; ====================================================================== +(define-class () + ((file :init-keyword :file :getter location-file) + (pos :init-keyword :pos :getter location-pos) + (line :init-keyword :line :getter location-line))) + +(define (location? obj) + (is-a? obj )) + +(define (ast-location obj) + (let ((loc (slot-ref obj 'loc))) + (if (location? loc) + (let* ((fname (location-file loc)) + (line (location-line loc)) + (pwd (getcwd)) + (len (string-length pwd)) + (lenf (string-length fname)) + (file (if (and (substring=? pwd fname len) + (> lenf len)) + (substring fname len (+ 1 (string-length fname))) + fname))) + (format "~a, line ~a" file line)) + "no source location"))) -- cgit v1.2.3