;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- ;;; $Header: /ct/interp/lana.l,v 1.91 85/06/21 12:31:59 bill Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; lana.l ;;; ;;; Paul Robertson January 30, 1983 ;;; ;;; ;;; ;;; The C*T Ada Interpreters Lexical Analyser ;;; ;;; ;;; ;;; This file is part of a proprietary software project. Source ;;; ;;; code and documentation describing implementation details are ;;; ;;; available on a confidential, non-disclosure basis only. These ;;; ;;; materials, including this file in particular, are trade secrets ;;; ;;; of Computer * Thought Corporation. ;;; ;;; ;;; ;;; (c) Copyright 1982 and 1983, Computer * Thought Corporation. ;;; ;;; All Rights Reserved. ;;; ;;; ;;; ;;; Reference materials: ;;; ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; ;;; Charniak et al., 198?. Artificial Intelligence Programming. ;;; ;;; ;;; ;;; The following code assumes familiarity with the above. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ensure presence of needed files. (eval-when (compile load eval) (ct_load 'aip)) ;AIP macros pkg. (eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg. (eval-when (compile load eval) (ct_load 'charmac)) ;Franz/LM compat pkg. (eval-when (compile load eval) (ct_load 'ctio)) ; New IO package (eval-when (compile load eval) (ct_load 'time)) ;Timing functions. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- (eval-when (compile load eval) (sstatus feature lexical_alternatives_enabled)) #+franz (declare (macros t)) (declare (special ; move to intrpdcl.l *visited_dnodes* ; delete *filename* *double_quote_alternative* *hash_alternative* )) (declare (ct_includef 'intrpdcl)) ; get the specials (eval-when (compile load eval) (ct_load 'ferec)) ; get the macros etc. (eval-when (compile load eval) (def_record_type la_stack_frame (currsymb charcount srcpos linpos))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Call-able Functions/Macros -- ;;; A very short lived demo program. ;;; (defun la_test_loop () ;;; (la_init) ; initialize the lana ;;; (setq ada_source (open ">paul>ada>primes.ada")) ;;; (do ((item (la_lex) (la_lex))) ;;; ((eq item 'lex_eof) nil) ;;; (ct_print item) ;;; (ct_terpri))) (defun la_test (fn) (setq *srcin* (open fn)) (la_test_port) (close *srcin*)) (defun la_resqueue () (fs:close-all-files)) (defun la_test_port() (la_init) ; initialize the lana (setq *symbolstack* nil) (setq *listout* (terminal_output) *eof_count* 0) (do ((item (la_startup) (la_lex))) ((eq item 'lex_eof) (ct_print 'lex_eof) (ct_terpri)) (ct_print la_current_symbol) (ct_terpri)) (la_finale)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Macros -- ;;; Predicate section ;;; This is a macro for defining Ada character type macros. It is called by ;;; (define_chartypes ) ;;; where is an atom and is an unquoted list of ascii ;;; values less than 256. it defines a function which can be ;;; called with an ascii values. ( ) is functionally similar ;;; to (memq ) except that uses arrays rather than ;;; memq lookup (and is therefore much faster). It also defines into an ;;; initialize function with the name _init. ( ) cannot ;;; be called until after (_init) is called ;;; (eval-when (eval compile load) (defun define_chartypes macro (body) (let ((type (cadr body)) (chars (caddr body))) `(progn 'compile ;; expands into initialize function (defun ,(concat type '_init) () ,@(mapcar #'(lambda (char) `(%= (#+franz funcall #+lispm aref #+franz (fdefinition '*la_char_table*) #+lispm *la_char_table* ,char) (cons ',type *_*))) chars)) ;; Defines the predicate (defun ,type (x) (and (> x 0) ;was breaking on end of file (-1) yuk.. PR (memq ',type (#+franz funcall #+lispm aref #+franz(fdefinition '*la_char_table*) #+lispm *la_char_table* x)))))))) ;;; Defines char table (and invisible line array) and c ;;; alls all of the necessary _init functions to initialize the ;;; char table (defun init_chartab () #+franz (array *la_char_table* t 256) ; Declare the character table #+lispm (setq *la_char_table* (make-array 256)) #+franz (array *la_invisible_line* t 256) #+lispm (setq *la_invisible_line* (make-array 256)) (do ((count 0 (1+ count))) ; Initialize its elements to nil ((eq count 256)) (%= (#+franz funcall #+lispm aref #+franz(fdefinition '*la_char_table*) #+lispm *la_char_table* count) nil)) (la_delimiter?_init) (la_delimiter2?_init) (white_space?_init)) ;;;Define all of the chartypes ;;; ;;; la_delimiter? - All of the possible first characters of an Ada delimiter (define_chartypes la_delimiter? ( 38 ; Ampersand. 39 ; Single Quote. 40 ; left paren. 41 ; Right paren. 91 ; left bracket. 93 ; right bracket. 42 ; star. 43 ; plus +. 44 ; comma ,. 45 ; minus -. 46 ; dot. 47 ; slash/. 58 ; colon:. 59 ; semicolon; . 60 ; less than<. 61 ; equals=. 62 ; greater than. 124 ; bar|. #+lexical_alternatives_enabled #/! )) ;;; la_delimiter2 - All of the possible second characters of an Ada delimiter (define_chartypes la_delimiter2? ( 42 ; star. 45 ; dash. 46 ; dot. 60 ; less than<. 61 ; equals=. 62 ; greater than. )) ;;; All of the possible "white" characters - characters (define_chartypes white_space? ( 32 ; space 9 #+lispm 137 ; tab 10 #+lispm 138 ; linefeed 12 ; form feed 13 #+lispm 141 ; carrage return )) ;;; Chartypes not defined by define_chartypes for efficiency (defun new_line? (ch) (or (eq ch #\newline) (eq ch #\return) #+franz (eq ch 12) #+lispm (eq ch 140))) (defun la_digit? (ch) (and (greaterp ch 47) (lessp ch 58))) ;;; Returns true if argument is a letter (upper or lower case). (defun la_letter? (ch) (or (and (> ch 96) (< ch 123)) ; a - z (and (> ch 64) (< ch 91)) ; A - Z ) ) ;;; If the status feature lexical_alternatives_enabled is set, these predicates ;;; allow the use of the legal replacements (|=>!, #=>:, and "=>%) (defun hash_characterp (ch) #+lexical_alternatives_enabled (cond ((null *hash_alternative*) (setq *hash_alternative* (car (memq ch '(#/# #/:))))) (t (= ch *hash_alternative*))) #-lexical_alternatives_enabled (= ch #/#)) (defun double_quote_characterp (ch) #+lexical_alternatives_enabled (cond ((null *double_quote_alternative*) (setq *double_quote_alternative* (car (memq ch '(#/" #/%))))) (t (= ch *double_quote_alternative*))) #-lexical_alternatives_enabled (= ch #/")) ;;; End of predicate section. ;;; Initialization functions ;;; Temporary hash function lexical analyser. ;(defun la_hash(l) ; l is a list on integers (characters) ; (apply 'times l)) (defun la_hash(l) (times (or (car l) 0) (apply 'plus l) (length l))) ;;; Initialize some variables that will be used by the lexical analyser (defun la_startup() (setq la_srcpos 1) ; on line one. (setq la_linpos 0) (setq la_psrcpos 1) ; on line one. (setq la_plinpos 0) (setq la_ppsrcpos 1) ; on line one. (setq la_pplinpos 0) (setq *charcount* 0) (setq *pcharcount* 0) (setq *la_newpages* 0) (setq *charstack* nil) (setq *produce_listing* t) (setq *double_quote_alternative* nil) (setq *hash_alternative* nil) (setq *gripes_pending* nil) (setq *buffered_gripes_pending* nil) (setq *la_current_line* nil) (setq *la_buffered_line* nil) (setq *la_collect_comments* nil) (setq *listing_switch* 1) (cond (*produce_listing* (ct_format *listout* "~%Line# Ada Source program~%~%"))) (setq la_comments nil) ; no comments yet. (setq la_current_ch 32) ; set initial char to white space. (la_lex)) ;;; Initialize the lexical analyzer. (defun la_init() (init_hash_table 5000) ; Symbol table of 5000 should suffice. (init_chartab) (putprop 'la_syntax (mapcar (function (lambda(op) (putprop (caddr op) 'terminal 'syntax_type) (la_op (car op) (exploden (car op)) (caddr op)))) '( ; All Ada's standard operators. ("--" |--| oper_comment) ; comment. ("," |,| oper_comma) ; comma (";" |;| oper_semicolon) ; semi-colon (".." |..| oper_dotdot) ; dot dot (":" |:| oper_colon) ; colon ("(" |(| oper_lparen) ; left paren ("[" |[| oper_lbracket) ; left bracket for pascal hackers. (")" |)| oper_rparen) ; right paren ("]" |]| oper_rbracket) ; right bracket for pascal hackers. ("<>" |<>| oper_ltgt) ; (":=" |:=| oper_assign) ; assign ("'" |'| oper_quote) ; quote ("." |.| oper_period) ; period #+lexical_alternatives_enabled ("/!" !! oper_bar) ; ++ SHRIEK #+lispm ("/|" /| oper_bar) ; bar #+franz ("\|" bar oper_bar) ; bar ("*" |*| oper_star) ; star ("**" |**| oper_starstar) ; star star #+lispm ("//" |//| oper_slash) ; slash #+franz ("/" \"slash oper_slash) ; Slash ("=" |=| oper_equals) ; equal #+lispm ("//=" |//=| oper_notequals) ; not equal #+franz ("/=" |/=| oper_notequals) ; not equal ("<" |<| oper_lt) ; less than ("<=" |<=| oper_le) ; less than or equal (">" |>| oper_gt) ; greater than (">=" |>=| oper_ge) ; greater than or equal ("+" |+| oper_plus) ; plus ("-" |-| oper_minus) ; minus ("&" |&| oper_ampersand) ; ampersand ("=>" |=>| oper_goes) ("<<" |<<| oper_mlt) (">>" |>>| oper_mgt) ) ) 'la_operators ) (putprop 'la_syntax ; Syntax information for the lexical ; analyser. (mapcar (function (lambda(rw) (putprop (caddr rw) 'terminal 'syntax_type) (la_rw (car rw) (exploden (car rw)) (caddr rw)))) '( ; All Ada's Reserved Words. ("abort" abort symb_abort) ("accept" accept symb_accept) ("access" access symb_access) ("all" all symb_all) ("and" and symb_and) ("array" array symb_array) ("at" at symb_at) ("begin" begin symb_begin) ("body" body symb_body) ("case" case symb_case) ("constant" constant symb_constant) ("declare" declare symb_declare) ("delay" delay symb_delay) ("delta" delta symb_delta) ("digits" digits symb_digits) ("do" do symb_do) ("else" else symb_else) ("elsif" elsif symb_elsif) ("end" end symb_end) ("entry" entry symb_entry) ("exception" exception symb_exception) ("exit" exit symb_exit) ("for" for symb_for) ("function" function symb_function) ("generic" generic symb_generic) ("goto" goto symb_goto) ("if" if symb_if) ("in" in symb_in) ("is" is symb_is) ("limited" limited symb_limited) ("loop" loop symb_loop) ("mod" mod symb_mod) ("new" new symb_new) ("not" not symb_not) ("null" null symb_null) ("of" of symb_of) ("or" or symb_or) ("others" others symb_others) ("out" out symb_out) ("package" package symb_package) ("pragma" pragma symb_pragma) ("private" private symb_private) ("procedure" procedure symb_procedure) ("raise" raise symb_raise) ("range" range symb_range) ("record" record symb_record) ("rem" rem symb_rem) ("renames" renames symb_renames) ("return" return symb_return) ("reverse" reverse symb_reverse) ("select" select symb_select) ("separate" separate symb_separate) ("subtype" subtype symb_subtype) ("task" task symb_task) ("terminate" terminate symb_terminate) ("then" then symb_then) ("type" type symb_type) ("use" use symb_use) ("when" when symb_when) ("while" while symb_while) ("with" with symb_with) ("xor" xor symb_xor) ) ) 'la_reserved_words ) (mapc (function (lambda(sy)(putprop sy 'terminal 'syntax_type))) '(lex_eof lex_string ; lex_char lex_ident lex_number)) (mapc (function (lambda(rw)(put_rw (la_rw%rname rw)(la_hash (la_rw%rname rw)) rw))) (get 'la_syntax 'la_reserved_words)) (mapc (function (lambda(op)(put_op (la_op%rname op)(la_hash (la_op%rname op)) op))) (get 'la_syntax 'la_operators)) nil ) ;;; RASSOC is not defined in Franz (defun rassoc_fixnum (item in-list) (do l in-list (cdr l) (null l) (and (equal item (getcharn (cdar l) 1)) (return (car l))))) ;;; Puts back a symbol. (defun putback_symbol(symbol) (ct_push (la_stack_frame la_current_symbol *charcount* la_srcpos la_linpos) *symbolstack*) ;stack this symbol for later. (setq *charcount* *pcharcount*) (setq la_linpos la_plinpos) (setq la_srcpos la_psrcpos) (setq *pcharcount* *ppcharcount*) (setq la_plinpos la_pplinpos) (setq la_psrcpos la_ppsrcpos) (%= la_current_symbol symbol)) ;;; Pop symbol stack (defun la_pop_symbolstack () (let ((stack_frame (ct_pop *symbolstack*))) ;;Pop stack's values for the source position (setq la_pplinpos la_plinpos) (setq la_ppsrcpos la_psrcpos) (setq *ppcharcount* *pcharcount*) (setq la_psrcpos la_srcpos) (setq la_plinpos la_linpos) (setq *pcharcount* *charcount*) (setq *charcount* (la_stack_frame%charcount stack_frame)) (setq la_srcpos (la_stack_frame%srcpos stack_frame)) (setq la_linpos (la_stack_frame%linpos stack_frame)) ;;Return symbol (la_stack_frame%currsymb stack_frame))) ;;; The Ada Lexical Analyser. (defun la_lex () ; Lexical Analyser Proper (setq la_current_symbol (cond (*symbolstack* (la_pop_symbolstack)) (t (setq *ppcharcount* *pcharcount*) (setq la_pplinpos la_plinpos) (setq la_ppsrcpos la_psrcpos) (setq *pcharcount* *charcount*) (setq la_plinpos la_linpos) (setq la_psrcpos la_srcpos) (let ((la_this_symbol nil) (*double_quote_alternative* nil) (*hash_alternative* nil) (la_ch (la_skip_white_space *srcin*))) ; (princ (ascii la_ch)) (cond ((la_digit? la_ch) ; Process number. (la_rdnumber la_ch)) ((eq la_ch #/.) ; Yet another Special Case (la_rddot)) ((la_letter? la_ch) ; identifier or reserved word. (la_rdsymbol la_ch)) ((la_delimiter? la_ch) ; operators delimiters character constants ; and comments. (la_rddelimiter la_ch)) ((double_quote_characterp la_ch) ; process string constant. (la_rdstring la_ch)) ((eq la_ch -1) ; end of file encountered. (cond ((greaterp *eof_count* 3) (la_gripe '("An unexpected end of file was encountered.") ) (*throw 'eof 'lex_eof)) (t (%= *eof_count* (add1 *_*)) 'lex_eof))) ((eq la_ch #/_) (la_gripe `("An underscore is not permitted here.") '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (nextchar *srcin*) (la_lex)) (t (la_gripe `(,(format nil "The ASCII character ~a is not part of the Ada character set, and may not appear in an Ada program." la_ch)) '((lrmref "LRM" (lrmsec 2 1 nil) (lrmpar 1 8)))) (nextchar *srcin*) (la_lex)))))))) ;;; reads Ada strings. (defun la_rdstring (ch) (do ((ch (nextchar *srcin*)(nextchar *srcin*))) ((and (double_quote_characterp ch) (not (double_quote_characterp (setq ch (nextchar *srcin*))))) (list 'lex_string (reverse la_this_symbol))) (cond ((eq ch -1) (la_gripe '("An unexpected end of file was encountered in a string.") '((lrmref "LRM" (lrmsec 2 6 nil) (lrmpar 1 6))) ) (return (list 'lex_string (reverse la_this_symbol)))) ((memq ch '(10 138 141)) (la_gripe '("Line separators are not allowed in strings.") '((lrmref "LRM" (lrmsec 2 6 nil) (lrmpar 6 nil)))) (return (list 'lex_string (reverse la_this_symbol))))) (cond ((legal_ch ch) (%= la_this_symbol (cons ch *_*))) (t (la_gripe `(,(format nil "The ASCII character ~a cannot appear in a string literal." ch)) '((lrmref "LRM" (lrmsec 2 6 nil) (lrmpar 3 nil)))))))) (defun legal_ch (ch) (or (and (<= ch #/Z) (>= ch #/A)) (and (<= ch #/z) (>= ch #/a)) (and (<= ch #/9) (>= ch #/0)) (memq ch '(#/" #/# #/& #/' #/( #/) #/* #/+ #/- #/. #// #/: #/; #/< #/= #/> #/_ #/| #/,)) (memq ch '(#/! #/$ #/% #/? #/@ #/[ #/] #/\ #/^ #/` #/{ #/} #/~)) (eq ch #\space))) (defun la_rddot() (let ((dch (nextchar *srcin*))) (%= la_this_symbol (cons #/. *_*)) (ct_selectq dch (#/. (%= la_this_symbol (cons #/. *_*)) (nextchar *srcin*) 'oper_dotdot) ((#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9) (la_rddigits dch 10.) (nextchar *srcin*) (la_gripe `("A number cannot begin with a decimal point(.).") '((lrmref "LRM" (lrmsec 2 5 7) (lrmpar 2 nil)))) (la_num 10. 0 0 t 0 0)) (otherwise ; (unnextchar dch *srcin*) 'oper_period)))) ;;; reads operators delimiters and comments. Fixed by Peter (defun la_rddelimiter (ch) ; read operators etc. (%= la_this_symbol (cons ch *_*)) (setq ch (nextchar *srcin*)) (cond ((la_delimiter2? ch) (%= la_this_symbol (cons ch *_*)))) ;;; here if end of delimiter reached. (setq la_this_symbol (reverse la_this_symbol)) (setq la_entry (get_op la_this_symbol (la_hash la_this_symbol))) (cond ((and (eq (car la_this_symbol) #/')); (null (new_line? ch))) (do ((i 1 (1+ i)) (chstack (cons ch nil) (cons (nextchar *srcin*) chstack))) ((or (= i 3) (and (> i 1) (= (car chstack) #/'))) (cond ((memq (car (reverse chstack)) '(#/" #/' #/_ #/# #-lexical_alternatives_enabled #/! #/$ #/@ #/% #/\ #/^ #/? #/` #/{ #/} #/~)) (mapc #'(lambda (c) (unnextchar c *srcin*)) (reverse (cdr (reverse chstack))))) (t (mapc #'(lambda (c) (unnextchar c *srcin*)) chstack))) (setq la_current_ch (nextchar *srcin*)) (setq la_this_symbol (cons 'oper_quote (cons (reverse (cdr chstack)) nil)))))) #| (let ((ch2 (nextchar *srcin*))) (cond ((eq ch2 #/') (nextchar *srcin*)`(oper_quote (,ch))) (t (unnextchar ch2 *srcin*) (setq la_current_ch ch) (la_op%intname la_entry))))) ; ++ identical to oper_quote (let ((ch2 (nextchar *srcin*))) (cond ((eq ch2 #/') (nextchar *srcin*) `(oper_quote (,ch))) (t (unnextchar ch2 *srcin*) (setq la_current_ch ch) (la_op%intname la_entry))))) ; ++ identical to oper_quote (cond ((= (car (cadr (first as))) #/')(la_lex))) ((= (car (cadr (first as))) #/")(nextchar *srcin*)) |# ((and la_entry (eq (la_op%intname la_entry) 'oper_comment)) (la_rdcomment *srcin*) ; read the comment (la_lex)) ; recursively invoke the lana. (la_entry (cond ((eq (length la_this_symbol) 2)(%= ch (nextchar *srcin*)))) (%= la_current_ch ch) (la_op%intname la_entry)) ((setq la_entry (get_op (list (first la_this_symbol)) (la_hash (list (first la_this_symbol))))) (la_op%intname la_entry)) (t (la_gripe `(,(format nil "The characters '~a' do not form a legal delimiter." (implode la_this_symbol))) '((lrmref "LRM" (lrmsec 2 2 nil) (lrmpar 5 7))))))) ;;; reads identifiers and reserved words. Returns a list if an identifier is ;;; found and a symbol otherwise. (defun la_rdsymbol (ch) ; Read identifier or reserved word. (do nil ((null (or (la_digit? ch) (la_letter? ch) (eq ch #/_))) ;;; Here if end of symbol reached. (setq la_this_symbol (reverse la_this_symbol)) (cond ((setq la_entry (get_rw la_this_symbol (la_hash la_this_symbol))) (la_rw%intname la_entry)) (t (list 'lex_ident la_this_symbol)))) (cond ((eq ch #/_) (%= la_this_symbol (cons ch *_*)) (setq ch (nextchar *srcin*)) (cond ((eq ch #/_) (do ((ach (nextchar *srcin*) (nextchar *srcin*))) ((null (eq ach #/_)) (setq ch ach) (ct_pop la_this_symbol)) (%= la_this_symbol (cons ach *_*))) (la_gripe `("Consecutive underscores are not permitted in identifiers.") '((lrmref "LRM" (lrmsec 2 3 nil) (lrmpar 2 4)))))) (cond ((null (or (la_letter? ch) (la_digit? ch))) (la_gripe '("Identifiers cannot be ended with underscores.") '((lrmref "LRM" (lrmsec 2 3 nil) (lrmpar 2 4))))) (t (%= la_this_symbol (cons ; identifiers and reserved words are not ; case sensitive. (cond ((and (> ch 64.)(< ch 91.))(+ ch 32)) (t ch)) *_*)) (setq ch (nextchar *srcin*))))) (t (%= la_this_symbol (cons ; identifiers and reserved words are not ; case sensitive. (cond ((and (> ch 64.)(< ch 91.))(+ ch 32)) (t ch)) *_*)) (setq ch (nextchar *srcin*)))))) ;;; Read number routine. Reads in a number record as follows. ;;; base integer ; defaults to 10 ;;; wholepart bignum ; defaults to 0 ;;; fractpart bignum ; defaults to 0 ;;; floatp t or nil ; t if number contained a period etc ;;; exp integer ; the exponent (0 if not specified). (declare (special *norm* *illegal_number*)) (defun illegal_digitp (ch) (let ((res (or (and (<= ch #/9) (>= ch #/0)) (and (<= ch #/Z ) (>= ch #/A)) (and (<= ch #/z ) (>= ch #/a))))) (cond (res (setq *illegal_number* ch) t) (t nil)))) (defun la_rdnumber (ch) ; read an Ada syntax number.Syntax 2.4 (prog nil (let ((base 10) (whole 0) (fract 0) (floatp nil) (exp 0); zero! (end_w_hashp nil)(*norm* 0)(*illegal_number* nil)) (setq whole (la_rddigits ch base)) (cond ((hash_characterp ch) ; (break hash-character) (cond ((or (eq (setq ch (nextchar *srcin*)) #/_) (la_digitify ch (setq base whole)) (illegal_digitp ch)) (setq end_w_hashp t) (setq whole (la_rddigits ch base))) ((or (illegal_digitp ch) (null (eq ch #/_))) (unnextchar ch *srcin*) (setq la_current_ch #+lexical_alternatives_enabled *hash_alternative* #-lexical_alternatives_enabled #/# )) (t (unnextchar ch *srcin*))))) (cond ((eq ch #/.) ; Dot .. could be part of a range. . here. (setq ch (la_eat_undersc t)) ;;check if an underscore or a space ;;la_gripe and remove (cond ((eq ch #/.) (ct_push (la_stack_frame 'oper_dotdot *charcount* la_srcpos la_linpos) *symbolstack*) (setq *charcount* *pcharcount*) (setq la_linpos la_plinpos) (setq la_srcpos la_psrcpos) (setq *pcharcount* *ppcharcount*) (setq la_plinpos la_pplinpos) (setq la_psrcpos la_ppsrcpos) (nextchar *srcin*) (return (la_num base whole fract floatp exp 0)))) (setq fract (la_rddigits ch base t)) ;side effect norm. (setq floatp (not (not fract))) (cond ((null floatp) (la_gripe '("A numeric literal may not end with a point.") '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))))))) (cond (end_w_hashp (cond ((hash_characterp ch) (setq ch (nextchar *srcin*))) (t (la_gripe '("The closing hash sign (#) of this based number is missing.") '((lrmref "LRM" (lrmsec 2 4 2) (lrmpar 1 4)) (lrmref "LRM" (lrmsec 2 4 2) (lrmpar 5 nil)))))))) (cond ((or (eq ch #/e) (eq ch #/E)) (let ((base 10)) (setq ch (la_eat_undersc t)) (cond ((eq ch #/+) (setq exp (la_rddigits (la_eat_undersc t) 10))) ((eq ch #/-) (cond (floatp (let ((res (la_rddigits (la_eat_undersc t) 10))) (setq exp (minus res)))) (t (la_gripe '("Integers cannot have negative exponents") '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 4 nil)))) 0))) (t (setq exp (la_rddigits ch 10))))))) (cond (*illegal_number* (la_gripe `(,(format nil "The ASCII character '~C' is incorrectly used in this numeric literal." *illegal_number*)) '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))))) (cond ((or (< base 2.) (> base 16.)) (la_gripe `(,(format nil "The bases of based literals must be between 2 and 16.")) '((lrmref "LRM" (lrmsec 2 4 2) (lrmpar 1 nil)) (lrmref "LRM" (lrmsec 2 4 2) (lrmpar 5 nil)))))) (return (cond ((null whole) (la_num base whole fract floatp (+ (1- *norm*) exp) (cond ((and floatp (null (zerop fract))) (fix (// (log fract) (log base)))) (t 0)))) (t (la_num base whole fract floatp exp (cond ((and floatp (null (zerop fract))) (- (fix (// (log fract) (log base))) (1- *norm*))) (t 0))))))))) ;;; Converts an ascii value to a number if the ascii value is a legal ;;; digit for that particular base (defun la_digitify (ach base) (setq ch ach) (cond ((and (greaterp ach 47) (lessp ach 58) (lessp (- ach 48) base)) (- ach 48)) ((and (greaterp ach 96) (lessp ach 123) (lessp (- ach 87) base)) (- ach 87)) ((and (greaterp ach 64) (lessp ach 91) (lessp (- ach 55) base)) (- ach 55)) ((or (eq ach #/e) (eq ach #/E)) nil) ; 123e3 is 123 to the 3 power #| ((and (greaterp ach 47) (lessp ach 58)) (la_gripe `(,(format nil "The ASCII character '~C' is incorrectly used in this numeric literal." ach)) '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (la_digitify (nextchar *srcin*) base)) ((and (greaterp ach 96) (lessp ach 123)) (la_gripe `(,(format nil "The ASCII character '~C' is incorrectly used in this numeric literal." ach)) '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (la_digitify (nextchar *srcin*) base)) ((and (greaterp ach 64) (lessp ach 91)) (la_gripe `(,(format nil "The ASCII character '~C' is incorrectly used in this numeric literal." ach)) '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (la_digitify (nextchar *srcin*) base)) |# (t nil))) ;;; Read in the next char that is not an underscore (_) ;;; consecutive underscores are a no-no pmj (defun la_eat_undersc (&optional (complain nil) (sectime nil)) (setq ch (nextchar *srcin*)) (cond ((eq ch 95) (cond (complain (la_gripe `("An underscore is not permitted here.") '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))))) (setq ch (nextchar *srcin*)) (cond ((eq ch #/_) (la_gripe '("Consecutive underscores are not permitted in numeric literals.") '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 3 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (do ((ch (nextchar *srcin*) (nextchar *srcin*))) ((not (eq ch 95)) ch))) ((and (greaterp ch 47) (lessp ch 58) (lessp (- ch 48) base)) ch) ((and (greaterp ch 96) (lessp ch 123) (lessp (- ch 87) base)) ch) ((and (greaterp ch 64) (lessp ch 91) (lessp (- ch 55) base)) ch) ((or (eq ch #/e) (eq ch #/E)) (la_gripe '("An underscore in a numeric literal may not appear next to an 'E'.") '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) ch) ((and (greaterp ch 47) (lessp ch 58)) (la_gripe `(,(format nil "The ASCII character '~C' is incorrectly used in this numeric literal." ch)) '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (la_eat_undersc nil t)) ((and (greaterp ch 96) (lessp ch 123)) (la_gripe `(,(format nil "The ASCII character '~C' is incorrectly used in this numeric literal." ch)) '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (la_eat_undersc nil t)) ((and (greaterp ch 64) (lessp ch 91)) (la_gripe `(,(format nil "The ASCII character '~C' is incorrectly used in this numeric literal." ch)) '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (la_eat_undersc nil t)) (t (la_gripe '("In this numeric literal, an underscore has not been followed by a legal digit.") '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (unnextchar ch *srcin*) ch))) ((and (greaterp ch 47) (lessp ch 58) (lessp (- ch 48) base)) ch) ((and (greaterp ch 96) (lessp ch 123) (lessp (- ch 87) base)) ch) ((and (greaterp ch 64) (lessp ch 91) (lessp (- ch 55) base)) ch) ((or (eq ch #/e) (eq ch #/E)) ch) ; 123e3 is 123 to the 3 power ((and (greaterp ch 47) (lessp ch 58)) (la_gripe `(,(format nil "The ASCII character '~C' is incorrectly used in this numeric literal." ch)) '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (la_eat_undersc nil t)) ((and (greaterp ch 96) (lessp ch 123)) (la_gripe `(,(format nil "The ASCII character '~C' is incorrectly used in this numeric literal." ch)) '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (la_eat_undersc nil t)) ((and (greaterp ch 64) (lessp ch 91)) (la_gripe `(,(format nil "The ASCII character '~C' is incorrectly used in this numeric literal." ch)) '((lrmref "LRM" (lrmsec 2 4 1) (lrmpar 2 nil)) (lrmref "LRM" (lrmsec 2 4 1) (lrmpar 5 nil)))) (la_eat_undersc nil t)) (t (cond (sectime (unnextchar ch *srcin*))) ch))) ;;; Read in some digits and return the numeric value corresponding to ;;; them in the specified base (defun la_rddigits (ach base &optional norm) (do ( (thisnum (la_digitify ach base) (+ (* thisnum base) (la_digitify ch base))) ) ((or (null thisnum) (null (la_digitify (setq ch (la_eat_undersc)) base))) thisnum) (cond ((and norm (zerop thisnum)(eq ach '#/0)) (setq *norm* (1- *norm*)))))) ;;; Reads characters from port until a non whitespace character is found. (defun la_skip_white_space (port) (do ((ch la_current_ch (nextchar port))) ((null (or (white_space? ch) ;Regular whitespace. (eq ch #\form) (and (eq ch 6)(nextchar port)))) ;Font prefixes. (progn (%= la_this_symbols_pos la_srcpos); A more accurate position. ch)) ) ) ;;; Function called after last line is lexed - it dumps both of the ;;; buffered lines (defun la_finale() (print_gripes) (setq la_srcpos (1+ la_srcpos)) (print_gripes)) ;;; Function called after a line is lexed.. (defun print_gripes() (cond ((eq la_srcpos 1) (setq *la_buffered_line* *la_current_line*) (setq *la_current_line* nil)) ((and *produce_listing* (null (eq la_srcpos 1))) (ct_terpri *listout*) (la_flush_buffre *listout*) ; (ct_princ (1- la_srcpos) *listout*) ; (ct_tyo #+franz 9 #+lispm 137. *listout*) ) ((null *produce_listing*) (setq *size_of_invisible* (1- la_linpos)))) (mapc (function (lambda(err) (generic_gripe (second err)))) (reverse *buffered_gripes_pending*)) ; printout the gripes (cond ((null (eq *la_newpages* 0)) (ct_terpri *listout*) (do nil ((eq *la_newpages* 0)) (ct_tyo #+lispm 140 #+franz 12 *listout*) (%= *la_newpages* (1- *_*))))) (cond ((eq *listing_switch* 0) (setq *listing_switch* 1) (setq *produce_listing* nil)) ((eq *listing_switch* 2) (setq *listing_switch* 1) (setq *produce_listing* t) (setq *la_buffered_line* (array_to_line (1- la_linpos))))) (setq *buffered_gripes_pending* *gripes_pending*) (setq *gripes_pending* nil)) ; reset gripe list ; (%= la_linpos 0) ; beginning of the line ; (%= la_srcpos (1+ *_*))) ;;; Dump out the buffered line (defun la_flush_buffre (stream) (cond (*produce_listing* (ct_format stream "~A ~A" (1- la_srcpos) (implode (reverse *la_buffered_line*))) ; (ct_princ (implode (append ; (exploden (1- la_srcpos)) ; (cons #\tab ; (exploden ; (reverse *la_buffered_line*))))) ; stream) (setq *la_buffered_line* *la_current_line*) (setq *la_current_line* nil)))) ;;; translates the *la_invisible_line*'s first size elements into a reversed ;;; list (defun array_to_line (size) (do ((index 1 (1+ index)) (res nil (cons (#+franz funcall #+lispm aref #+franz(fdefinition '*la_invisible_line*) #+lispm *la_invisible_line* index) res))) ((> index size) res))) ;;; Buffer a character so that it will be the value of the next nextchar (defun unnextchar (char port) (ct_push char *charstack*)) ;;; Gets the next character from the source program (or the char buffer). (defun nextchar (port) (cond (*charstack* (setq la_current_ch (ct_pop *charstack*))) (t (cond ((eq la_current_ch #+lispm #\return #+franz #\linefeed) (%= la_linpos 0) (%= la_srcpos (1+ *_*)))) (setq *charcount* (cond ((or (eq la_current_ch font_change_ch) (eq la_current_ch -1.)) *charcount*) (t (1+ *charcount*))) la_current_ch (ct_tyi port -1)) ;;get the next character from the stream. (cond ((eq la_current_ch #\tab) (%= la_linpos (times 8 (quotient (+ 8 *_*) 8)))) ((eq la_current_ch font_change_ch) la_linpos) (t (%= la_linpos (1+ *_*)))) (cond ((or (eq la_current_ch #\linefeed) (eq la_current_ch #\return)) (print_gripes)) ((and *produce_listing* (> la_current_ch 0) (not (eq font_change_ch la_current_ch))) (%= *la_current_line* (cons la_current_ch *_*))) ((null *produce_listing*) (%= (#+franz funcall #+lispm aref #+franz (fdefinition '*la_invisible_line*) #+lispm *la_invisible_line* la_linpos) la_current_ch))) (cond ((and (null (white_space? la_current_ch)) (>= la_current_ch 200.)) ; lozenge (la_gripe `(,(format nil "You forgot to put in the ~C" la_current_ch))) (nextchar port)) ((eq la_current_ch font_change_ch) ;;If its a font change sequence. (%= *charcount* (1+ *_*)) (%= *charcount* (1+ *_*)) (%= la_linpos (1+ *_*)) (%= la_linpos (1+ *_*)) (ct_tyi port -1) ; font # (nextchar port)) (t la_current_ch))))) ; try again. #| (cond ((eq (ct_tyi port -1) 73) ; lozenge font (%= *charcount* (1+ *_*)) (la_gripe `("You forgot to put in the " ,(car (rassoc_fixnum (ct_tyi port -1) *editor-lozenge-alist*)))))) |# ;;;Check to see if the next thing looks like a comment (defun comment-p (port) (let* ((old_la_current_ch la_current_ch) (char1 (la_skip_white_space port)) char2) (cond ((char-equal char1 #/-) (cond ((char-equal (setq char2 (nextchar port)) #/-) t) (t (unnextchar char2 port) (unnextchar char1 port) (setq la_current_ch old_la_current_ch) nil))) (t (unnextchar char1 port) (setq la_current_ch old_la_current_ch) nil)))) ;;;New la_rdcomment to eliminate recursion in la_lex --wab (defun la_rdcomment (port) (setq *la_collect_comments* t) (loop for comment? = t then (comment-p port) while comment? do (cond (*la_collect_comments* (do ((comment (list la_current_ch) (cons (nextchar port) comment))) ((member (car comment) '(10 138 141 -1)) ; wait for end of line. (%= la_comments (append1 *_* (implode (reverse (cdr comment)))))))) (t (do nil ((member la_current_ch '(10 138 141 -1))) (nextchar port)))))) ;;;old version --wab 6-17-85 #| ;;; Reads comment and puts on to the end of the list la_comments. (defun la_rdcomment (port) (cond (*la_collect_comments* (do ((comment (list la_current_ch) (cons (nextchar port) comment))) ((member (car comment) '(10 138 141 -1)) ; wait for end of line. (%= la_comments (append1 *_* (implode (reverse (cdr comment)))))))) (t (do nil ((member la_current_ch '(10 138 141 -1))) (nextchar port))))) |# ;;; Functions to peek at the source associated with diana nodes ;;; ;;; diana_src_peek ;;; (defun diana_src_peek (node) (let ((dnode (diana_get node 'lx_srcpos))) (display (source_region%path dnode) (source_region%startchar dnode) (source_region%endchar dnode)) )) ;;; ;;; display ;;; (defun display (pathname from to) (errset (with_open_infile (srcfile pathname) (prog (pos) (setq pos from) #+lispm (ct_send srcfile ':set-pointer from) #+franz (filepos srcfile from) loop (cond ;((or (lessp pos to) (equal pos to)) ((lessp pos to) (tyo (tyi srcfile 88.)) (setq pos (add1 pos)) (go loop))))))) ;;; eof ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun diana_peek_test_int (frob mom) (cond ((not (and frob (or (listp frob) (diana_nodep frob)))) );Rock Bottom. ((diana_nodep frob) (cond ((and (not (memq (diana_get frob 'ct_id) *visited_dnodes*)) (eq (source_region%path (diana_get frob 'lx_srcpos)) *filename*)) (ct_push (diana_get frob 'ct_id) *visited_dnodes*) (princ "The diana node is:") (terpri) (diana_pprint frob 3) (terpri) (diana_src_peek frob) (terpri) (diana_mapc #'(lambda (attr val) (cond ((memq attr '(ct_cont ct_thread ct_id sm_defn sm_first sm_deff_occurence as_subprogram_def))) (t (diana_peek_test_int val frob)))) frob)))) ((not (diana_nodep (car frob))) ) ;Lex_item or something. (t ;A list of at least 1 Diana node. (do ((rest frob (cdr rest))) ((null (cdr rest)) (diana_peek_test_int (car rest) mom)) (diana_peek_test_int (car rest) mom))))) (defun diana_peek_test (frob) (setq *visited_dnodes* nil) (setq *filename* (source_region%path (diana_get frob 'lx_srcpos))) (diana_peek_test_int frob nil) "DONE!!")