From ccc7e34619661c676b8169c3d88360f070b49b51 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Wed, 15 Jun 2005 17:35:06 +0000 Subject: Started a port of Skribe to Guile. * src/guile: New directory. Contains the beginning of a Guile implementation that borrows most of its code to the STkLos implementation of Skribe. git-archimport-id: lcourtes@laas.fr--2004-libre/skribilo--devel--1.2--patch-4 --- src/guile/skribe/types.scm | 314 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 314 insertions(+) create mode 100644 src/guile/skribe/types.scm (limited to 'src/guile/skribe/types.scm') diff --git a/src/guile/skribe/types.scm b/src/guile/skribe/types.scm new file mode 100644 index 0000000..2ec7318 --- /dev/null +++ b/src/guile/skribe/types.scm @@ -0,0 +1,314 @@ +;;;; +;;;; 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-module (skribe types) ;; FIXME: Why should it be a separate module? + :export ( ast? ast-loc ast-loc-set! + command? command-fmt command-body + unresolved? unresolved-proc + handle? handle-ast + node? node-options node-loc + engine? engine-ident engine-format engine-customs + engine-filter engine-symbol-table + writer? write-object + processor? processor-combinator processor-engine + markup? bind-markup! markup-options is-markup? + markup-body find-markups write-object + container? container-options + container-ident container-body + document? document-ident document-body + document-options document-end + language? + location? ast-location + + *node-table*) + :use-module (oop goops)) + +(define *node-table* (make-hash-table)) + ; 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 () + (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 :init-form '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 () + (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-set! *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-ref *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 () + (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