aboutsummaryrefslogtreecommitdiff
path: root/src/bigloo/lisp.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/bigloo/lisp.scm')
-rw-r--r--src/bigloo/lisp.scm530
1 files changed, 530 insertions, 0 deletions
diff --git a/src/bigloo/lisp.scm b/src/bigloo/lisp.scm
new file mode 100644
index 0000000..65a8227
--- /dev/null
+++ b/src/bigloo/lisp.scm
@@ -0,0 +1,530 @@
+;*=====================================================================*/
+;* serrano/prgm/project/skribe/src/bigloo/lisp.scm */
+;* ------------------------------------------------------------- */
+;* Author : Manuel Serrano */
+;* Creation : Fri Aug 29 08:14:59 2003 */
+;* Last change : Mon Nov 8 14:32:22 2004 (serrano) */
+;* Copyright : 2003-04 Manuel Serrano */
+;* ------------------------------------------------------------- */
+;* Handling of lispish source files. */
+;*=====================================================================*/
+
+;*---------------------------------------------------------------------*/
+;* The module */
+;*---------------------------------------------------------------------*/
+(module skribe_lisp
+
+ (include "new.sch")
+
+ (import skribe_types
+ skribe_lib
+ skribe_resolve
+ skribe_eval
+ skribe_api
+ skribe_param
+ skribe_source)
+
+ (export bigloo
+ scheme
+ lisp
+ skribe))
+
+;*---------------------------------------------------------------------*/
+;* keys ... */
+;*---------------------------------------------------------------------*/
+(define *the-key* #f)
+(define *bracket-highlight* #t)
+(define *bigloo-key* #f)
+(define *scheme-key* #f)
+(define *lisp-key* #f)
+(define *skribe-key* #f)
+
+;*---------------------------------------------------------------------*/
+;* init-bigloo-fontifier! ... */
+;*---------------------------------------------------------------------*/
+(define (init-bigloo-fontifier!)
+ (if (not *bigloo-key*)
+ (begin
+ (set! *bigloo-key* (gensym))
+ ;; language keywords
+ (for-each (lambda (symbol)
+ (putprop! symbol *bigloo-key* 'symbol))
+ '(set! if let cond case quote begin letrec let*
+ lambda export extern class generic inline
+ static import foreign type with-access instantiate
+ duplicate labels
+ match-case match-lambda
+ syntax-rules pragma widen! shrink!
+ wide-class profile profile/gc
+ regular-grammar lalr-grammar apply))
+ ;; define
+ (for-each (lambda (symbol)
+ (putprop! symbol *bigloo-key* 'define))
+ '(define define-inline define-struct define-macro
+ define-generic define-method define-syntax
+ define-expander))
+ ;; error
+ (for-each (lambda (symbol)
+ (putprop! symbol *bigloo-key* 'error))
+ '(bind-exit unwind-protect call/cc error warning))
+ ;; module
+ (for-each (lambda (symbol)
+ (putprop! symbol *bigloo-key* 'module))
+ '(module import export library))
+ ;; thread
+ (for-each (lambda (symbol)
+ (putprop! symbol *bigloo-key* 'thread))
+ '(make-thread thread-start! thread-yield!
+ thread-await! thread-await*!
+ thread-sleep! thread-join!
+ thread-terminate! thread-suspend!
+ thread-resume! thread-yield!
+ thread-specific thread-specific-set!
+ thread-name thread-name-set!
+ scheduler-react! scheduler-start!
+ broadcast! scheduler-broadcast!
+ current-thread thread?
+ current-scheduler scheduler? make-scheduler
+ make-input-signal make-output-signal
+ make-connect-signal make-process-signal
+ make-accept-signal make-timer-signal
+ thread-get-values! thread-get-values*!)))))
+
+;*---------------------------------------------------------------------*/
+;* init-lisp-fontifier! ... */
+;*---------------------------------------------------------------------*/
+(define (init-lisp-fontifier!)
+ (if (not *lisp-key*)
+ (begin
+ (set! *lisp-key* (gensym))
+ ;; language keywords
+ (for-each (lambda (symbol)
+ (putprop! symbol *lisp-key* 'symbol))
+ '(setq if let cond case else progn letrec let*
+ lambda labels try unwind-protect apply funcall))
+ ;; defun
+ (for-each (lambda (symbol)
+ (putprop! symbol *lisp-key* 'define))
+ '(define defun defvar defmacro)))))
+
+;*---------------------------------------------------------------------*/
+;* init-skribe-fontifier! ... */
+;*---------------------------------------------------------------------*/
+(define (init-skribe-fontifier!)
+ (if (not *skribe-key*)
+ (begin
+ (set! *skribe-key* (gensym))
+ ;; language keywords
+ (for-each (lambda (symbol)
+ (putprop! symbol *skribe-key* 'symbol))
+ '(set! bold it emph tt color ref index underline
+ figure center pre flush hrule linebreak
+ image kbd code var samp sc sf sup sub
+ itemize description enumerate item
+ table tr td th item prgm author
+ prgm hook font lambda))
+ ;; define
+ (for-each (lambda (symbol)
+ (putprop! symbol *skribe-key* 'define))
+ '(define define-markup))
+ ;; markup
+ (for-each (lambda (symbol)
+ (putprop! symbol *skribe-key* 'markup))
+ '(document chapter section subsection subsubsection
+ paragraph p handle resolve processor
+ abstract margin toc table-of-contents
+ current-document current-chapter current-section
+ document-sections* section-number
+ footnote print-index include skribe-load
+ slide)))))
+
+;*---------------------------------------------------------------------*/
+;* bigloo ... */
+;*---------------------------------------------------------------------*/
+(define bigloo
+ (new language
+ (name "bigloo")
+ (fontifier bigloo-fontifier)
+ (extractor bigloo-extractor)))
+
+;*---------------------------------------------------------------------*/
+;* scheme ... */
+;*---------------------------------------------------------------------*/
+(define scheme
+ (new language
+ (name "scheme")
+ (fontifier scheme-fontifier)
+ (extractor scheme-extractor)))
+
+;*---------------------------------------------------------------------*/
+;* lisp ... */
+;*---------------------------------------------------------------------*/
+(define lisp
+ (new language
+ (name "lisp")
+ (fontifier lisp-fontifier)
+ (extractor lisp-extractor)))
+
+;*---------------------------------------------------------------------*/
+;* bigloo-fontifier ... */
+;*---------------------------------------------------------------------*/
+(define (bigloo-fontifier s)
+ (init-bigloo-fontifier!)
+ (set! *the-key* *bigloo-key*)
+ (set! *bracket-highlight* #f)
+ (fontify-lisp (open-input-string s)))
+
+;*---------------------------------------------------------------------*/
+;* bigloo-extractor ... */
+;*---------------------------------------------------------------------*/
+(define (bigloo-extractor iport def tab)
+ (definition-search iport
+ tab
+ (lambda (exp)
+ (match-case exp
+ (((or define define-inline define-generic
+ define-method define-macro define-expander)
+ (?fun . ?-) . ?-)
+ (eq? def fun))
+ (((or define define-struct define-library) (and (? symbol?) ?var) . ?-)
+ (eq? var def))
+ (else
+ #f)))))
+
+;*---------------------------------------------------------------------*/
+;* skribe ... */
+;*---------------------------------------------------------------------*/
+(define skribe
+ (new language
+ (name "skribe")
+ (fontifier skribe-fontifier)
+ (extractor skribe-extractor)))
+
+;*---------------------------------------------------------------------*/
+;* skribe-fontifier ... */
+;*---------------------------------------------------------------------*/
+(define (skribe-fontifier s)
+ (init-skribe-fontifier!)
+ (set! *the-key* *skribe-key*)
+ (set! *bracket-highlight* #t)
+ (fontify-lisp (open-input-string s)))
+
+;*---------------------------------------------------------------------*/
+;* skribe-extractor ... */
+;*---------------------------------------------------------------------*/
+(define (skribe-extractor iport def tab)
+ (definition-search iport
+ tab
+ (lambda (exp)
+ (match-case exp
+ (((or define define-macro define-markup) (?fun . ?-) . ?-)
+ (eq? def fun))
+ ((define (and (? symbol?) ?var) . ?-)
+ (eq? var def))
+ ((markup-output (quote ?mk) . ?-)
+ (eq? mk def))
+ (else
+ #f)))))
+
+;*---------------------------------------------------------------------*/
+;* scheme-fontifier ... */
+;*---------------------------------------------------------------------*/
+(define (scheme-fontifier s) s)
+
+;*---------------------------------------------------------------------*/
+;* scheme-extractor ... */
+;*---------------------------------------------------------------------*/
+(define (scheme-extractor iport def tab)
+ (definition-search iport
+ tab
+ (lambda (exp)
+ (match-case exp
+ (((or define define-macro) (?fun . ?-) . ?-)
+ (eq? def fun))
+ ((define (and (? symbol?) ?var) . ?-)
+ (eq? var def))
+ (else
+ #f)))))
+
+;*---------------------------------------------------------------------*/
+;* lisp-fontifier ... */
+;*---------------------------------------------------------------------*/
+(define (lisp-fontifier s)
+ (init-lisp-fontifier!)
+ (set! *the-key* *lisp-key*)
+ (set! *bracket-highlight* #f)
+ (fontify-lisp (open-input-string s)))
+
+;*---------------------------------------------------------------------*/
+;* lisp-extractor ... */
+;*---------------------------------------------------------------------*/
+(define (lisp-extractor iport def tab)
+ (definition-search iport
+ tab
+ (lambda (exp)
+ (match-case exp
+ (((or defun defmacro) ?fun ?- . ?-)
+ (eq? def fun))
+ ((defvar ?var . ?-)
+ (eq? var def))
+ (else
+ #f)))))
+
+;*---------------------------------------------------------------------*/
+;* definition-search ... */
+;* ------------------------------------------------------------- */
+;* This function seeks a Bigloo definition. If it finds it, it */
+;* returns two values the starting char number of the definition */
+;* and the stop char. */
+;*---------------------------------------------------------------------*/
+(define (definition-search ip tab semipred)
+ (cond-expand
+ (bigloo2.6
+ (define (reader-current-line-number)
+ (let* ((port (open-input-string "(9)"))
+ (exp (read port #t)))
+ (close-input-port port)
+ (line-number exp)))
+ (define (line-number expr)
+ (and (epair? expr)
+ (match-case (cer expr)
+ ((at ?- ?pos ?line)
+ line))))
+ (reader-reset!)
+ (let loop ((exp (read ip #t)))
+ (if (not (eof-object? exp))
+ (let ((v (semipred exp)))
+ (if (not v)
+ (loop (read ip #t))
+ (let* ((b (line-number exp))
+ (e (reader-current-line-number)))
+ (source-read-lines (input-port-name ip) b e tab)))))))
+ (else
+ (define (char-number expr)
+ (and (epair? expr)
+ (match-case (cer expr)
+ ((at ?- ?pos)
+ pos))))
+ (let loop ((exp (read ip #t)))
+ (if (not (eof-object? exp))
+ (let ((v (semipred exp)))
+ (if (not v)
+ (loop (read ip #t))
+ (let* ((b (char-number exp))
+ (e (input-port-position ip)))
+ (source-read-chars (input-port-name ip)
+ b
+ e
+ tab)))))))))
+
+
+;*---------------------------------------------------------------------*/
+;* fontify-lisp ... */
+;*---------------------------------------------------------------------*/
+(define (fontify-lisp port::input-port)
+ (let ((g (regular-grammar ()
+ ((: ";;" (* all))
+ ;; italic comments
+ (let ((c (new markup
+ (markup '&source-comment)
+ (body (the-string)))))
+ (cons c (ignore))))
+ ((: ";*" (* all))
+ ;; bold comments
+ (let ((c (new markup
+ (markup '&source-line-comment)
+ (body (the-string)))))
+ (cons c (ignore))))
+ ((: ";" (out #\; #\*) (* all))
+ ;; plain comments
+ (let ((str (the-string)))
+ (cons str (ignore))))
+ ((: #\\ (* (in #\space #\tab)) ";" (out #\; #\*) (* all))
+ ;; plain comments
+ (let ((str (the-substring 1 (the-length))))
+ (cons str (ignore))))
+ ((+ #\Space)
+ ;; separators
+ (let ((str (the-string)))
+ (cons (highlight str) (ignore))))
+ (#\(
+ ;; open parenthesis
+ (let ((str (highlight (the-string))))
+ (pupush-highlight)
+ (cons str (ignore))))
+ (#\)
+ ;; close parenthesis
+ (let ((str (highlight (the-string) -1)))
+ (cons str (ignore))))
+ ((+ (in "[]"))
+ ;; brackets
+ (let ((s (the-string)))
+ (if *bracket-highlight*
+ (let ((c (new markup
+ (markup '&source-bracket)
+ (body s))))
+ (cons c (ignore)))
+ (cons s (ignore)))))
+ ((+ #\Tab)
+ (let ((str (the-string)))
+ (cons (highlight str) (ignore))))
+ ((: #\( (+ (out "; \t()[]:\"\n")))
+ ;; keywords
+ (let* ((string (the-substring 1 (the-length)))
+ (symbol (string->symbol string))
+ (key (getprop symbol *the-key*)))
+ (cons
+ "("
+ (case key
+ ((symbol)
+ (let ((c (new markup
+ (markup '&source-keyword)
+ (ident (symbol->string (gensym)))
+ (body string))))
+ (cons c (ignore))))
+ ((define)
+ (let ((c (new markup
+ (markup '&source-define)
+ (body string))))
+ (push-highlight (lambda (e)
+ (new markup
+ (markup '&source-define)
+ (ident (symbol->string (gensym)))
+ (body e)))
+ 1)
+ (cons c (ignore))))
+ ((error)
+ (let ((c (new markup
+ (markup '&source-error)
+ (ident (symbol->string (gensym)))
+ (body string))))
+ (cons c (ignore))))
+ ((module)
+ (let ((c (new markup
+ (markup '&source-module)
+ (ident (symbol->string (gensym)))
+ (body string))))
+ (push-highlight (lambda (e)
+ (new markup
+ (markup '&source-module)
+ (ident (symbol->string (gensym)))
+ (body e)))
+ 1)
+ (cons c (ignore))))
+ ((markup)
+ (let ((c (new markup
+ (markup '&source-markup)
+ (ident (symbol->string (gensym)))
+ (body string))))
+ (cons c (ignore))))
+ ((thread)
+ (let ((c (new markup
+ (markup '&source-thread)
+ (ident (symbol->string (gensym)))
+ (body string))))
+ (cons c (ignore))))
+ (else
+ (cons (highlight string 1) (ignore)))))))
+ ((+ (out "; \t()[]:\"\n"))
+ (let ((string (the-string)))
+ (cons (highlight string 1) (ignore))))
+ ((+ #\Newline)
+ ;; newline
+ (let ((str (the-string)))
+ (cons (highlight str) (ignore))))
+ ((or (: "\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\"")
+ (: "#\"" (* (or (out #a000 #\\ #\") (: #\\ all))) "\""))
+ ;; strings
+ (let ((str (split-string-newline (the-string))))
+ (append (map (lambda (s)
+ (if (eq? s 'eol)
+ "\n"
+ (new markup
+ (markup '&source-string)
+ (ident (symbol->string (gensym)))
+ (body s))))
+ str)
+ (ignore))))
+ ((: "::" (+ (out ";\n \t()[]:\"")))
+ ;; type annotations
+ (let ((c (new markup
+ (markup '&source-type)
+ (ident (symbol->string (gensym)))
+ (body (the-string)))))
+ (cons c (ignore))))
+ ((: ":" (out ":()[] \n\t\"") (* (out ";\n \t()[]:\"")))
+ ;; keywords annotations
+ (let ((c (new markup
+ (markup '&source-key)
+ (ident (symbol->string (gensym)))
+ (body (the-string)))))
+ (cons c (ignore))))
+ ((+ (or #\: #\; #\"))
+ (let ((str (the-string)))
+ (cons (highlight str 1) (ignore))))
+ ((: #\# #\\ (+ (out " \n\t")))
+ ;; characters
+ (let ((str (the-string)))
+ (cons (highlight str 1) (ignore))))
+ (else
+ (let ((c (the-failure)))
+ (if (eof-object? c)
+ '()
+ (error "source(lisp)" "Unexpected character" c)))))))
+ (reset-highlight!)
+ (read/rp g port)))
+
+;*---------------------------------------------------------------------*/
+;* *highlight* ... */
+;*---------------------------------------------------------------------*/
+(define *highlight* '())
+
+;*---------------------------------------------------------------------*/
+;* reset-highlight! ... */
+;*---------------------------------------------------------------------*/
+(define (reset-highlight!)
+ (set! *highlight* '()))
+
+;*---------------------------------------------------------------------*/
+;* push-highlight ... */
+;*---------------------------------------------------------------------*/
+(define (push-highlight col pv)
+ (set! *highlight* (cons (cons col pv) *highlight*)))
+
+;*---------------------------------------------------------------------*/
+;* pupush-highlight ... */
+;*---------------------------------------------------------------------*/
+(define (pupush-highlight)
+ (if (pair? *highlight*)
+ (let ((c (car *highlight*)))
+ (set-cdr! c 100000))))
+
+;*---------------------------------------------------------------------*/
+;* pop-highlight ... */
+;*---------------------------------------------------------------------*/
+(define (pop-highlight pv)
+ (case pv
+ ((-1)
+ (set! *highlight* (cdr *highlight*)))
+ ((0)
+ 'nop)
+ (else
+ (let ((c (car *highlight*)))
+ (if (>fx (cdr c) 1)
+ (set-cdr! c (-fx (cdr c) 1))
+ (set! *highlight* (cdr *highlight*)))))))
+
+;*---------------------------------------------------------------------*/
+;* highlight ... */
+;*---------------------------------------------------------------------*/
+(define (highlight exp . pop)
+ (if (pair? *highlight*)
+ (let* ((c (car *highlight*))
+ (r (if (>fx (cdr c) 0)
+ ((car c) exp)
+ exp)))
+ (if (pair? pop) (pop-highlight (car pop)))
+ r)
+ exp))
+
+
generated by cgit v1.2.3 (git 2.45.0) at 2024-06-29 07:43:28 +0000