path: root/legacy/stklos/types.stk

;;;;
;;;; types.stk	-- Definition of Skribe classes
;;;; 
;;;; 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: 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.


;;;; ======================================================================
;;;;
;;;;				<AST>
;;;;
;;;; ======================================================================
;;FIXME: set! location in <ast> 
(define-class <ast> ()
  ((parent :accessor ast-parent :init-keyword :parent :init-form 'unspecified)
   (loc    :init-form #f)))

(define (ast? obj)    		(is-a? obj <ast>))
(define (ast-loc obj) 		(slot-ref obj 'loc))
(define (ast-loc-set! obj v) 	(slot-set! obj 'loc v))

;;;; ======================================================================
;;;;
;;;;				<COMMAND>
;;;;
;;;; ======================================================================
(define-class <command> (<ast>)
  ((fmt    :init-keyword :fmt)
   (body   :init-keyword :body)))

(define (command? obj)     (is-a? obj <command>))
(define (command-fmt obj)  (slot-ref obj 'fmt))
(define (command-body obj) (slot-ref obj 'body))

;;;; ======================================================================
;;;;
;;;;				<UNRESOLVED>
;;;;
;;;; ======================================================================
(define-class <unresolved> (<ast>)
  ((proc :init-keyword :proc)))

(define (unresolved? obj)     (is-a? obj <unresolved>))
(define (unresolved-proc obj) (slot-ref obj 'proc))

;;;; ======================================================================
;;;;
;;;;				<HANDLE>
;;;;
;;;; ======================================================================
(define-class <handle> (<ast>)
  ((ast :init-keyword :ast :init-form #f :getter handle-ast)))

(define (handle? obj)     (is-a? obj <handle>))
(define (handle-ast obj)  (slot-ref obj 'ast))


;;;; ======================================================================
;;;;
;;;;				<NODE>
;;;;
;;;; ======================================================================
(define-class <node> (<ast>)
  ((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 <node>))
(define (node-options obj) (slot-ref obj 'options))
(define node-loc 	   ast-loc)


;;;; ======================================================================
;;;;
;;;;				<PROCESSOR>
;;;;
;;;; ======================================================================
(define-class <processor> (<node>)
  ((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 <processor>))
(define (processor-combinator obj) (slot-ref obj 'combinator))
(define (processor-engine obj)     (slot-ref obj 'engine))

;;;; ======================================================================
;;;;
;;;;				<MARKUP>
;;;;
;;;; ======================================================================
(define-class <markup> (<node>)
  ((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 <markup>) initargs)
  (next-method)
  (bind-markup! self))


(define (markup? obj)  		(is-a? obj <markup>))
(define (markup-options obj)	(slot-ref obj 'options))
(define markup-body    node-body)


(define (is-markup? obj markup)
  (and (is-a? obj <markup>)
       (eq? (slot-ref obj 'markup) markup)))



(define (find-markups ident)
  (hash-table-get *node-table* ident #f))


(define-method write-object ((obj <markup>) port)
  (format port "#[~A (~A/~A) ~A]"
	  (class-name (class-of obj))
	  (slot-ref obj 'markup)
	  (slot-ref obj 'ident)
	  (address-of obj)))

;;;; ======================================================================
;;;;
;;;;				<CONTAINER>
;;;;
;;;; ======================================================================
(define-class <container> (<markup>)
  ((env :init-keyword :env :init-form '())))

(define (container? obj)    (is-a? obj <container>))
(define (container-env obj) (slot-ref obj 'env))
(define container-options   markup-options) 
(define container-ident     markup-ident)
(define container-body      node-body)



;;;; ======================================================================
;;;;
;;;;				<DOCUMENT>
;;;;
;;;; ======================================================================
(define-class <document> (<container>)
  ())

(define (document? obj)      (is-a? obj <document>))
(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)


;;;; ======================================================================
;;;;
;;;;				<ENGINE>
;;;;
;;;; ======================================================================
(define-class <engine> ()
  ((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 <engine>))

(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))


;;;; ======================================================================
;;;;
;;;;				<WRITER>
;;;;
;;;; ======================================================================
(define-class <writer> ()
  ((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 <writer>))

(define-method write-object ((obj <writer>) port)
  (format port "#[~A (~A) ~A]"
	  (class-name (class-of obj))
	  (slot-ref obj 'ident)
	  (address-of obj)))
  
;;;; ======================================================================
;;;;
;;;;				<LANGUAGE>
;;;;
;;;; ======================================================================
(define-class <language> ()
  ((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 <language>))
  

;;;; ======================================================================
;;;;
;;;;				<LOCATION>
;;;;
;;;; ======================================================================
(define-class <location> ()
  ((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 <location>))

(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")))