home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
plbin.zip
/
pl
/
lisp
/
qptokens.el
< prev
next >
Wrap
Lisp/Scheme
|
1992-05-26
|
8KB
|
260 lines
;;; SCCS: @(#)90/11/15 qptokens.el 2.3
;;; Quintus Prolog - GNU Emacs Interface
;;; Support Functions
;;;
;;; Consolidated by Sitaram Muralidhar
;;;
;;; sitaram@quintus.com
;;; Quintus Computer Systems, Inc.
;;; 2 May 1989
;;;
;;; This file defines functions that support the Quintus Prolog - GNU Emacs
;;; interface.
;;;
;;; Acknowledgements
;;;
;;
;;; This interface was made possible by contributions from Fernando
;;; Pereira and various customers of Quintus Computer Systems, Inc.,
;;; based on code for Quintus's Unipress Emacs interface.
;;;
;;; Functions defined in this file are:
;;; - region-to-string()
;;; - BadToken(message)
;;; - next-token()
;;; - pre-preceding-char()
(defun region-to-string ()
(buffer-substring (min (point) (mark)) (max (point) (mark))))
(defmacro pattern-at-point (x)
(list 'and (list 'looking-at x) '(goto-char (match-end 0)) t))
(defvar *digits*
"0123456789AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz")
(defvar *character-escapes* nil)
(defun BadToken (message)
(error message))
(defun pre-preceding-char ()
(let (char)
(if (bobp)
(setq char -1)
(progn
(backward-char)
(setq char (preceding-char))
(forward-char)))
char
))
(defun next-token ()
(let ((char (following-char)) ttype)
(set-mark (point))
(cond
((eobp) (setq ttype "eof"))
((and (>= char ?a) (<= char ?z))
(forward-char)
(pattern-at-point "[A-Za-z_0-9]*")
(if (= (following-char) ?\()
(setq ttype "functor")
(setq ttype "atom")))
((or (and (>= char ?\001) (<= char ? )) (= char ?\177))
(forward-char)
(pattern-at-point "[\001- \177]*")
(setq ttype (next-token)))
((or
(= char ?,) (= char ?\) ) (= char ?\( )
(= char ?\| ) (= char ?]) (= char ?}))
(forward-char)
(setq ttype (char-to-string char)))
((and (>= char ?A) (<= char ?Z))
(forward-char)
(pattern-at-point "[A-Za-z_0-9]*")
(setq ttype "variable"))
((or (= char ?#) (= char ?$) (= char ?&) (= char ?*) (= char ?+)
(= char ?-) (= char ?:) (= char ?<) (= char ?=) (= char ?>)
(= char ?\?) (= char ?@) (= char ?\\) (= char ?^) (= char ?`)
(= char ?~))
(forward-char)
(pattern-at-point "[-+*/\\^<>=`~:.?@#$&]*")
(if (= (following-char) ?\( )
(setq ttype "functor")
(setq ttype "atom")
))
((= char ?_ )
(forward-char)
(pattern-at-point "[A-Za-z_0-9]*")
(setq ttype "variable"))
((and (>= char ?0) (<= char ?9))
(forward-char)
(pattern-at-point "[0-9]*")
(if (= (following-char) ?\')
(let ((base (string-to-int (region-to-string))) x)
(cond
((= base 0) (setq ttype "integer"))
((< base 10)
(forward-char)
(setq x (substring *digits* 0 base))
(if (pattern-at-point (concat "[" x "][" x "]*"))
(setq ttype "integer")
(progn
(backward-char)
(setq ttype "integer"))
)
)
((< base 37)
(forward-char)
(setq x (substring *digits* 0 (+ 10 (* 2 (- base 10)))))
(if (pattern-at-point (concat "[" x "][" x "]*"))
(setq ttype "integer")
(progn
(backward-char)
(setq ttype "integer"))
)
)
(t (setq ttype "integer"))
)
)
(if (= (following-char) ?.)
(progn
(forward-char)
(if (or (eobp) (looking-at "[?\001- ?\177]"))
(progn
(backward-char)
(setq ttype "integer"))
(if (not (pattern-at-point "[0-9][0-9]*"))
(BadToken "Floating point number has no decimal digits")
(if (not (pattern-at-point "[eE]"))
(setq ttype "float")
(if (and (not (pattern-at-point "[0-9][0-9]*"))
(not (pattern-at-point "[-+][0-9][0-9]*")))
(progn
(backward-char)
(setq ttype "float")
)
(setq ttype "float")
)
)
)
)
)
(setq ttype "integer")
)
)
)
((= char ?.)
(forward-char)
(if (and (not (eobp))
(not (pattern-at-point "[\001- \177]")))
(progn
(pattern-at-point "[-+*/\\^<>=`~:.?@#$&]*")
(if (= (following-char) ?\( )
(setq ttype "functor")
(setq ttype "atom")))
(setq ttype "stop")))
((= char ?\')
(let ((continue t))
(forward-char)
(while continue
(if (not (search-forward "'" nil t))
(BadToken "Quoted atom not closed")
(if *character-escapes*
(if (not (= (pre-preceding-char) ?\\))
(if (not (pattern-at-point "'"))
(setq continue nil)))
(if (not (pattern-at-point "'"))
(setq continue nil)))))
(if (= (following-char) ?\( )
(setq ttype "functor")
(setq ttype "atom")
)))
((= char ?% )
(forward-char)
(pattern-at-point ".*\n")
(setq ttype (next-token)))
((= char ?/)
(forward-char)
(if (not (pattern-at-point "\\*"))
(progn
(pattern-at-point "[-+*/\\^<>=`~:.?@#$&]*")
(if (= (following-char) ?\( )
(setq ttype "functor")
(setq ttype "atom")
)
)
(if (not (search-forward "*/" nil t))
(BadToken "Delimited comment not closed")
(setq ttype (next-token))
)
)
)
((or (= char ?!) (= char ?\; ))
(forward-char)
(if (= (following-char) ?\( )
(setq ttype "functor")
(setq ttype "atom")
)
)
((= char ?[ )
(forward-char)
(if (= (following-char) ?])
(progn
(forward-char)
(if (= (following-char) ?\( )
(setq ttype "functor")
(setq ttype "atom")
)
)
(setq ttype "[")
)
)
((= char ?\")
(let ((continue t))
(forward-char)
(while continue
(if (not (search-forward """" nil t))
(BadToken "Quoted string not closed")
(if *character-escapes*
(if (not (= (pre-preceding-char) ?\\))
(if (not (pattern-at-point "\""))
(setq continue nil)
)
)
(if (not (pattern-at-point "\""))
(setq continue nil)
)
)
)
)
(setq ttype "string")
))
((= char ?{)
(forward-char)
(if (= (following-char) ?})
(progn
(forward-char)
(if (= (following-char) ?\()
(setq ttype "functor")
(setq ttype "atom")
)
)
(setq ttype "{")
)
)
((= char ?\000)
(forward-char)
(BadToken (concat "Cannot handle "
(char-to-string char)
" as a token"))
)
)
ttype
))