diff options
Diffstat (limited to 'src/bigloo/types.scm')
| -rw-r--r-- | src/bigloo/types.scm | 685 |
1 files changed, 685 insertions, 0 deletions
diff --git a/src/bigloo/types.scm b/src/bigloo/types.scm new file mode 100644 index 0000000..b8babd4 --- /dev/null +++ b/src/bigloo/types.scm @@ -0,0 +1,685 @@ +;*=====================================================================*/ +;* serrano/prgm/project/skribe/src/bigloo/types.scm */ +;* ------------------------------------------------------------- */ +;* Author : Manuel Serrano */ +;* Creation : Tue Jul 22 16:40:42 2003 */ +;* Last change : Thu Oct 21 13:23:17 2004 (serrano) */ +;* Copyright : 2003-04 Manuel Serrano */ +;* ------------------------------------------------------------- */ +;* The definition of the Skribe classes */ +;*=====================================================================*/ + +;*---------------------------------------------------------------------*/ +;* The module */ +;*---------------------------------------------------------------------*/ +(module skribe_types + + (export (abstract-class %ast + (parent (default #unspecified)) + (loc (default (evmeaning-location)))) + + (class %command::%ast + (fmt::bstring read-only) + (body (default #f))) + + (class %unresolved::%ast + (proc::procedure read-only)) + + (class %handle::%ast + (ast (default #f))) + + (abstract-class %node::%ast + (required-options::pair-nil read-only (default '())) + (options::pair-nil (default '())) + (body (default #f))) + + (class %processor::%node + (combinator (default (lambda (e1 e2) e1))) + (procedure::procedure (default (lambda (n e) n))) + engine) + + (class %markup::%node + (markup-init) + (ident (default #f)) + (class (default #f)) + (markup::symbol read-only)) + + (class %container::%markup + (env::pair-nil (default '()))) + + (class %document::%container) + + (class %engine + (ident::symbol read-only) + (format::bstring (default "raw")) + (info::pair-nil (default '())) + (version::obj read-only (default #unspecified)) + (delegate read-only (default #f)) + (writers::pair-nil (default '())) + (filter::obj (default #f)) + (customs::pair-nil (default '())) + (symbol-table::pair-nil (default '()))) + + (class %writer + (ident::symbol read-only) + (class read-only) + (pred::procedure read-only) + (upred read-only) + (options::obj read-only) + (verified?::bool (default #f)) + (validate (default #f)) + (before read-only) + (action read-only) + (after read-only)) + + (class %language + (name::bstring read-only) + (fontifier read-only (default #f)) + (extractor read-only (default #f))) + + (markup-init ::%markup) + (find-markups ::bstring) + + (inline ast?::bool ::obj) + (inline ast-parent::obj ::%ast) + (inline ast-loc::obj ::%ast) + (inline ast-loc-set!::obj ::%ast ::obj) + (ast-location::bstring ::%ast) + + (new-command . inits) + (inline command?::bool ::obj) + (inline command-fmt::bstring ::%command) + (inline command-body::obj ::%command) + + (new-unresolved . inits) + (inline unresolved?::bool ::obj) + (inline unresolved-proc::procedure ::%unresolved) + + (new-handle . inits) + (inline handle?::bool ::obj) + (inline handle-ast::obj ::%handle) + + (inline node?::bool ::obj) + (inline node-body::obj ::%node) + (inline node-options::pair-nil ::%node) + (inline node-loc::obj ::%node) + + (new-processor . inits) + (inline processor?::bool ::obj) + (inline processor-combinator::obj ::%processor) + (inline processor-engine::obj ::%processor) + + (new-markup . inits) + (inline markup?::bool ::obj) + (inline is-markup?::bool ::obj ::symbol) + (inline markup-markup::obj ::%markup) + (inline markup-ident::obj ::%markup) + (inline markup-body::obj ::%markup) + (inline markup-options::pair-nil ::%markup) + + (new-container . inits) + (inline container?::bool ::obj) + (inline container-ident::obj ::%container) + (inline container-body::obj ::%container) + (inline container-options::pair-nil ::%container) + + (new-document . inits) + (inline document?::bool ::obj) + (inline document-ident::bool ::%document) + (inline document-body::bool ::%document) + (inline document-options::pair-nil ::%document) + (inline document-env::pair-nil ::%document) + + (inline engine?::bool ::obj) + (inline engine-ident::obj ::obj) + (inline engine-format::obj ::obj) + (inline engine-customs::pair-nil ::obj) + (inline engine-filter::obj ::obj) + (inline engine-symbol-table::pair-nil ::%engine) + + (inline writer?::bool ::obj) + (inline writer-before::obj ::%writer) + (inline writer-action::obj ::%writer) + (inline writer-after::obj ::%writer) + (inline writer-options::obj ::%writer) + + (inline language?::bool ::obj) + (inline language-name::obj ::obj) + (inline language-fontifier::obj ::obj) + (inline language-extractor::obj ::obj) + + (new-language . inits) + + (location?::bool ::obj) + (location-file::bstring ::pair) + (location-pos::int ::pair))) + +;*---------------------------------------------------------------------*/ +;* skribe-instantiate ... */ +;*---------------------------------------------------------------------*/ +(define-macro (skribe-instantiate type values . slots) + `(begin + (skribe-instantiate-check-values ',type ,values ',slots) + (,(symbol-append 'instantiate::% type) + ,@(map (lambda (slot) + (let ((id (if (pair? slot) (car slot) slot)) + (def (if (pair? slot) (cadr slot) #f))) + `(,id (new-get-value ',id ,values ,def)))) + slots)))) + +;*---------------------------------------------------------------------*/ +;* skribe-instantiate-check-values ... */ +;*---------------------------------------------------------------------*/ +(define (skribe-instantiate-check-values id values slots) + (let ((bs (every (lambda (v) (not (memq (car v) slots))) values))) + (when (pair? bs) + (for-each (lambda (b) + (error (symbol-append '|new | id) + "Illegal field" + b)) + bs)))) + +;*---------------------------------------------------------------------*/ +;* object-print ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-print obj::%ast port print-slot::procedure) + (let* ((class (object-class obj)) + (class-name (class-name class))) + (display "#|" port) + (display class-name port) + (display #\| port))) + +;*---------------------------------------------------------------------*/ +;* object-display ::%ast ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-display n::%ast . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a>" + (find-runtime-type n))) + +;*---------------------------------------------------------------------*/ +;* object-display ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-display n::%markup . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a:~a>" + (find-runtime-type n) + (markup-markup n))) + +;*---------------------------------------------------------------------*/ +;* object-write ::%markup ... */ +;*---------------------------------------------------------------------*/ +(define-method (object-write n::%markup . port) + (fprintf (if (pair? port) (car port) (current-output-port)) + "<#~a:~a:~a>" + (find-runtime-type n) + (markup-markup n) + (find-runtime-type (markup-body n)))) + +;*---------------------------------------------------------------------*/ +;* *node-table* */ +;* ------------------------------------------------------------- */ +;* A private hashtable that stores all the nodes of an ast. It */ +;* is used for retreiving a node from its identifier. */ +;*---------------------------------------------------------------------*/ +(define *node-table* (make-hashtable)) + +;*---------------------------------------------------------------------*/ +;* ast? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast? obj) + (%ast? obj)) + +;*---------------------------------------------------------------------*/ +;* ast-parent ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-parent obj) + (%ast-parent obj)) + +;*---------------------------------------------------------------------*/ +;* ast-loc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-loc obj) + (%ast-loc obj)) + +;*---------------------------------------------------------------------*/ +;* ast-loc-set! ... */ +;*---------------------------------------------------------------------*/ +(define-inline (ast-loc-set! obj loc) + (%ast-loc-set! obj loc)) + +;*---------------------------------------------------------------------*/ +;* ast-location ... */ +;*---------------------------------------------------------------------*/ +(define (ast-location obj) + (with-access::%ast obj (loc) + (if (location? loc) + (let* ((fname (location-file loc)) + (char (location-pos loc)) + (pwd (pwd)) + (len (string-length pwd)) + (lenf (string-length fname)) + (file (if (and (substring=? pwd fname len) + (and (>fx lenf len))) + (substring fname len (+fx 1 (string-length fname))) + fname))) + (format "~a, char ~a" file char)) + "no source location"))) + +;*---------------------------------------------------------------------*/ +;* new-command ... */ +;*---------------------------------------------------------------------*/ +(define (new-command . init) + (skribe-instantiate command init + (parent #unspecified) + (loc #f) + fmt + (body #f))) + +;*---------------------------------------------------------------------*/ +;* command? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command? obj) + (%command? obj)) + +;*---------------------------------------------------------------------*/ +;* command-fmt ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command-fmt cmd) + (%command-fmt cmd)) + +;*---------------------------------------------------------------------*/ +;* command-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (command-body cmd) + (%command-body cmd)) + +;*---------------------------------------------------------------------*/ +;* new-unresolved ... */ +;*---------------------------------------------------------------------*/ +(define (new-unresolved . init) + (skribe-instantiate unresolved init + (parent #unspecified) + loc + proc)) + +;*---------------------------------------------------------------------*/ +;* unresolved? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unresolved? obj) + (%unresolved? obj)) + +;*---------------------------------------------------------------------*/ +;* unresolved-proc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (unresolved-proc unr) + (%unresolved-proc unr)) + +;*---------------------------------------------------------------------*/ +;* new-handle ... */ +;*---------------------------------------------------------------------*/ +(define (new-handle . init) + (skribe-instantiate handle init + (parent #unspecified) + loc + (ast #f))) + +;*---------------------------------------------------------------------*/ +;* handle? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (handle? obj) + (%handle? obj)) + +;*---------------------------------------------------------------------*/ +;* handle-ast ... */ +;*---------------------------------------------------------------------*/ +(define-inline (handle-ast obj) + (%handle-ast obj)) + +;*---------------------------------------------------------------------*/ +;* node? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node? obj) + (%node? obj)) + +;*---------------------------------------------------------------------*/ +;* node-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-body obj) + (%node-body obj)) + +;*---------------------------------------------------------------------*/ +;* node-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-options obj) + (%node-options obj)) + +;*---------------------------------------------------------------------*/ +;* node-loc ... */ +;*---------------------------------------------------------------------*/ +(define-inline (node-loc obj) + (%node-loc obj)) + +;*---------------------------------------------------------------------*/ +;* new-processor ... */ +;*---------------------------------------------------------------------*/ +(define (new-processor . init) + (skribe-instantiate processor init + (parent #unspecified) + loc + (combinator (lambda (e1 e2) e1)) + engine + (body #f))) + +;*---------------------------------------------------------------------*/ +;* processor? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor? obj) + (%processor? obj)) + +;*---------------------------------------------------------------------*/ +;* processor-combinator ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor-combinator proc) + (%processor-combinator proc)) + +;*---------------------------------------------------------------------*/ +;* processor-engine ... */ +;*---------------------------------------------------------------------*/ +(define-inline (processor-engine proc) + (%processor-engine proc)) + +;*---------------------------------------------------------------------*/ +;* new-markup ... */ +;*---------------------------------------------------------------------*/ +(define (new-markup . init) + (skribe-instantiate markup init + (parent #unspecified) + (loc #f) + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()))) + +;*---------------------------------------------------------------------*/ +;* markup? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup? obj) + (%markup? obj)) + +;*---------------------------------------------------------------------*/ +;* is-markup? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (is-markup? obj markup) + (and (markup? obj) (eq? (markup-markup obj) markup))) + +;*---------------------------------------------------------------------*/ +;* markup-init ... */ +;* ------------------------------------------------------------- */ +;* The markup constructor simply stores in the markup table the */ +;* news markups. */ +;*---------------------------------------------------------------------*/ +(define (markup-init markup) + (bind-markup! markup)) + +;*---------------------------------------------------------------------*/ +;* bind-markup! ... */ +;*---------------------------------------------------------------------*/ +(define (bind-markup! node) + (hashtable-update! *node-table* + (markup-ident node) + (lambda (cur) (cons node cur)) + (list node))) + +;*---------------------------------------------------------------------*/ +;* find-markups ... */ +;*---------------------------------------------------------------------*/ +(define (find-markups ident) + (hashtable-get *node-table* ident)) + +;*---------------------------------------------------------------------*/ +;* markup-markup ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-markup obj) + (%markup-markup obj)) + +;*---------------------------------------------------------------------*/ +;* markup-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-ident obj) + (%markup-ident obj)) + +;*---------------------------------------------------------------------*/ +;* markup-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-body obj) + (%markup-body obj)) + +;*---------------------------------------------------------------------*/ +;* markup-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (markup-options obj) + (%markup-options obj)) + +;*---------------------------------------------------------------------*/ +;* new-container ... */ +;*---------------------------------------------------------------------*/ +(define (new-container . init) + (skribe-instantiate container init + (parent #unspecified) + loc + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()) + (env '()))) + +;*---------------------------------------------------------------------*/ +;* container? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container? obj) + (%container? obj)) + +;*---------------------------------------------------------------------*/ +;* container-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-ident obj) + (%container-ident obj)) + +;*---------------------------------------------------------------------*/ +;* container-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-body obj) + (%container-body obj)) + +;*---------------------------------------------------------------------*/ +;* container-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (container-options obj) + (%container-options obj)) + +;*---------------------------------------------------------------------*/ +;* new-document ... */ +;*---------------------------------------------------------------------*/ +(define (new-document . init) + (skribe-instantiate document init + (parent #unspecified) + loc + markup + ident + (class #f) + (body #f) + (options '()) + (required-options '()) + (env '()))) + +;*---------------------------------------------------------------------*/ +;* document? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document? obj) + (%document? obj)) + +;*---------------------------------------------------------------------*/ +;* document-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-options doc) + (%document-options doc)) + +;*---------------------------------------------------------------------*/ +;* document-env ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-env doc) + (%document-env doc)) + +;*---------------------------------------------------------------------*/ +;* document-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-ident doc) + (%document-ident doc)) + +;*---------------------------------------------------------------------*/ +;* document-body ... */ +;*---------------------------------------------------------------------*/ +(define-inline (document-body doc) + (%document-body doc)) + +;*---------------------------------------------------------------------*/ +;* engine? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine? obj) + (%engine? obj)) + +;*---------------------------------------------------------------------*/ +;* engine-ident ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-ident obj) + (%engine-ident obj)) + +;*---------------------------------------------------------------------*/ +;* engine-format ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-format obj) + (%engine-format obj)) + +;*---------------------------------------------------------------------*/ +;* engine-customs ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-customs obj) + (%engine-customs obj)) + +;*---------------------------------------------------------------------*/ +;* engine-filter ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-filter obj) + (%engine-filter obj)) + +;*---------------------------------------------------------------------*/ +;* engine-symbol-table ... */ +;*---------------------------------------------------------------------*/ +(define-inline (engine-symbol-table obj) + (%engine-symbol-table obj)) + +;*---------------------------------------------------------------------*/ +;* writer? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer? obj) + (%writer? obj)) + +;*---------------------------------------------------------------------*/ +;* writer-before ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-before obj) + (%writer-before obj)) + +;*---------------------------------------------------------------------*/ +;* writer-action ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-action obj) + (%writer-action obj)) + +;*---------------------------------------------------------------------*/ +;* writer-after ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-after obj) + (%writer-after obj)) + +;*---------------------------------------------------------------------*/ +;* writer-options ... */ +;*---------------------------------------------------------------------*/ +(define-inline (writer-options obj) + (%writer-options obj)) + +;*---------------------------------------------------------------------*/ +;* language? ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language? obj) + (%language? obj)) + +;*---------------------------------------------------------------------*/ +;* language-name ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-name lg) + (%language-name lg)) + +;*---------------------------------------------------------------------*/ +;* language-fontifier ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-fontifier lg) + (%language-fontifier lg)) + +;*---------------------------------------------------------------------*/ +;* language-extractor ... */ +;*---------------------------------------------------------------------*/ +(define-inline (language-extractor lg) + (%language-extractor lg)) + +;*---------------------------------------------------------------------*/ +;* new-get-value ... */ +;*---------------------------------------------------------------------*/ +(define (new-get-value key init def) + (let ((c (assq key init))) + (match-case c + ((?- ?v) + v) + (else + def)))) + +;*---------------------------------------------------------------------*/ +;* new-language ... */ +;*---------------------------------------------------------------------*/ +(define (new-language . init) + (skribe-instantiate language init name fontifier extractor)) + +;*---------------------------------------------------------------------*/ +;* location? ... */ +;*---------------------------------------------------------------------*/ +(define (location? o) + (match-case o + ((at ?- ?-) + #t) + (else + #f))) + +;*---------------------------------------------------------------------*/ +;* location-file ... */ +;*---------------------------------------------------------------------*/ +(define (location-file o) + (match-case o + ((at ?fname ?-) + fname) + (else + (error 'location-file "Illegal location" o)))) + +;*---------------------------------------------------------------------*/ +;* location-pos ... */ +;*---------------------------------------------------------------------*/ +(define (location-pos o) + (match-case o + ((at ?- ?loc) + loc) + (else + (error 'location-pos "Illegal location" o)))) |