;;; -*- mode:lisp;package:user;base:10.;fonts: cptfontb -*- ;;; ;;; $Header: /ct/interp/ioflav.l,v 1.53 84/09/25 23:02:02 alex Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IOFLAV ;;; ;;; John Shelton, Mark Miller, Alex C. Meng 17-May-83 ;;; ;;; ;;; ;;; This file contains code to implement the flavors necessary for ;;; ;;; text input and output. It is designed to run in either Franz or ;;; ;;; Zeta LISP, on Vax/Unix, Vax/VMS, or LM2's. ;;; ;;; ;;; ;;; 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: ;;; ;;; Foderaro and Sklower, The FRANZ LISP Manual, September 1981. ;;; ;;; Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981. ;;; ;;; Charniak et al., 1980. Artificial Intelligence Programming. ;;; ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; ;;; AJPO, Feb 1983. ANSI/MIL-STD-1815A Ada Reference Manual. ;;; ;;; The following code assumes familiarity with these materials. ;;; ;;; ;;; ;;; ASSUMES CT_LOAD AND SUITABLE FILEMAP ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ensure presence of needed files. (eval-when (compile load eval) (ct_load 'charmac));CT char set extensions. (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 'ctflav));Compatible flavors. (eval-when (compile load eval) (ct_load 'iocompat)) (eval-when (compile load eval) ;With_ada_parameters macro. (ct_load 'bifmacs)) (eval-when (compile load eval) ;For ada_raise. (ct_load 'dsmacs)) (eval-when (compile load eval) ;For string package (ct_load 'ctstrl)) (eval-when (compile load eval) (ct_load 'diana)) ; diana structure ;;; This file is loaded by text_io. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #+franz (declare (macros t)) (declare (ct_includef 'intrpdcl)) ;;; Because we repeatedly use exploden, implode, and maknam: #+lispm (declare (setq obsolete-function-warning-switch nil)) ;NB++mlm ;;; Some constants that you should know about: ;;; (these are defined in io_compat). (declare (special *ada_eol* ; This char delimits lines. *ada_eop* ; This char delimits pages *ada_eof*)) ; This char ends every file. ;;; These characters are generated automatically under most ;;; circumstances. Ada code never requires you to manipulate the ;;; characters. Procedures like WRITE_LINE generate the chars for you, ;;; and writing past line and page boundaries (if there are any) will do ;;; this for you. For complete flexibility, the methods below will ;;; handle character strings with the EOx characters in them, making the ;;; appropriate calculations. There should be no reason, however, to ;;; make use of this feature. ;;; Very few string operations are used here. ZetaLisp has plenty, but ;;; FranzLisp is sorely lacking in string functionality. Perhaps the ;;; worst missing feature is that of simple decomposition of strings via ;;; Array Referencing. This means that to look at a character in a ;;; string, you either have to decompose it using EXPLODEN, or take a ;;; single-character substring, which is probably expensive anyway. ;;; NB++mlm: I have not worked through all of the algorithms in detail, ;;; but I am concerned about the use of generic versus typed arithmetic. ;;; I think these were probably tested primarily on the LISPM, where ;;; the differences do not matter, but on Franz, some uses of integer-only ;;; functions may occur in places where a flonum could appear, say. ;;; In several cases I changed to generic functions when I was not sure. ;;; This in itself might be an error, however, if the original code was ;;; counting on implicit conversion by truncation or something. ;;; The raising of exceptions has not been entirely checked against ;;; the LRM yet. ++mlm ;;; Compiler Declarations and Global Variables, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables, continued -- ;;; These next spevars perhaps should go in intrpdcl. ?? ++mlm ;;; I changed defconsts and defvars to declares and setq's since the ;;; more verbose form is "safer" in some situations involving reloading ;;; files on some dialects (sigh). (declare (special *ada_default_original_input* *ada_default_original_output* *item_chars* *digits* *baser* *signs* *spaces* *underscore* *extended* *exp_start* *exp_sign_int* *exp_sign_real* *radix_point* *else* *int_error* *delimiter* *integer_table* *real_table* *accept_states* *actions* *ada_default_output* *ada_default_input* *fsm_base* *fsm_number* *fsm_exp* *fsm_sign* *fsm_exp_sign* *fsm_radix* )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Used Functions/Macros/Flavors/Methods -- ;;;;;;;;;;;;;;;;; (ct_defflavor ada_output_stream ;;;;;;;;;;;;;;;;; ;;; Use one of these for any kind of output. The Ada procedures to ;;; write to streams can all be hacked with these, too. You should ;;; specify a max column and max line when instantiating this. ;;; The above line is not and should not be a necesity,the LRM spells ;;; out explicitly that the line and page length are UNBOUNDED by ;;; default, changed by **AM** . ;;; Current column, line, and page are NEVER manipulated directly. ;;; (that is the whole idea behind having a flavor for this.) These are ;;; automatically adjusted for you as you output things. Any output ;;; sent to an ada_output_stream is directly printed right away; there ;;; is no need to buffer output, since once a character is written, ;;; there is no way to look at it again. Note that it is not an error ;;; to write after the EOF character, though it makes no sense. (real_stream (name "Unnamed Output Stream") (current_column 1) (current_line 0) (current_page 0) (max_column 0) (max_line 0) (line_buf nil) (last_out_char nil) status ; Something like OPEN or CLOSED. ) () :settable-instance-variables :gettable-instance-variables) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;; (ct_defflavor ada_input_stream ;;;;;;;;;;;;;;;; ;;; Use one of these for any kind of input. The Ada procedures to input ;;; from strings can be hacked with these, too. You do NOT need max ;;; column and line, because they would make no sense with input. ;;; Current column, line, and page are NEVER manipulated by the user. ;;; They are automatically adjusted as things are read. An input buffer ;;; is used because it is sometimes necessary to look forward several ;;; characters. (Eg., to detect EOF, you may have to look past EOL, ;;; EOP.) Stuff is read into the input buffer in chunks in some ;;; efficient manner that is not of any concern to the user. The ;;; instance variable TRUE-END-OF-FILE is TRUE when no more characters ;;; can actually be read, even if the EOF char has not been found. An ;;; error of some kind is raised if the TRUE EOF is found, and no EOF ;;; char. If terminal_style_io is T, we assume this stream is linked to ;;; a terminal, and we DON'T want to read ahead (peek) very much. (real_stream (name "Unnamed Input Stream") (input_buffer nil) (current_column 0) (current_line 0) (current_page 0) status ; Something like OPEN or CLOSED. (true_end_of_file nil) ; If T, at physical end of file. (terminal_style_io nil) ) () :initable-instance-variables :settable-instance-variables :gettable-instance-variables) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Default Streams (now that the flavors exist). ; NB: I am not sure that the defaults here are right, versus using ; (standard_input), say, instead of (terminal_input). ++mlm ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq *ada_default_original_input* ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_make_instance 'ada_input_stream 'real_stream (terminal_input) 'name "*ada_default_original_input*" 'terminal_style_io t 'status 'open)) (cond ((not (boundp '*ada_default_input*)) ;;;;;;;;;;;;;;;;;;; (setq *ada_default_input* ;;;;;;;;;;;;;;;;;;; (ct_make_instance 'ada_input_stream 'real_stream (terminal_input) 'name "*ada_default_input*" 'terminal_style_io t 'status 'open)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq *ada_default_original_output* ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_make_instance 'ada_output_stream 'real_stream (terminal_output) 'name "*ada_default_original_output*" 'max_column 80. ; Truly gross use of a constant. 'status 'open)) ; It should look at termcap!! ++mlm (cond ((not (boundp '*ada_default_output*)) ;;;;;;;;;;;;;;;;;;;; (setq *ada_default_output* ;;;;;;;;;;;;;;;;;;;; (ct_make_instance 'ada_output_stream 'real_stream (terminal_output) 'name "*ada_default_output*" 'max_column 80. 'status 'open)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; General Information About Files ;;;;;;;; (defun get_mode (file) ; Returns 'input or 'output. ;;;;;;;; (let ((obj (ct_typep file))) (cond ((equal obj 'ada_input_stream) 'input) ((equal obj 'ada_output_stream) 'output)))) ;;;;;;;;;; (defun get_status (file) ; Returns 'open or 'closed. ;;;;;;;;;; (let ((obj (ct_typep file))) (cond ((equal obj 'ada_input_stream) (get-iv ada_input_stream file 'status)) ((equal obj 'ada_output_stream) (get-iv ada_output_stream file 'status))))) ;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream mode) () 'input) ;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream mode) () 'output) ;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;; (defun get_name (file) ;;;;;;;; (let ((obj (ct_typep file))) (cond ((equal obj 'ada_input_stream) (get-iv ada_input_stream file 'name)) ((equal obj 'ada_output_stream) (get-iv ada_output_stream file 'name))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Opening Files. ;;; Seems like possible problem here, compared with sequen_io, in ;;; that there is redundant coding. ok?? ++mlm ;;;;;;;;;;;;;; (defun open_for_input (filename) ; Returns an ada_input_stream. ;;;;;;;;;;;;;; (ct_make_instance 'ada_input_stream 'real_stream (ct_if (ct_probef filename) (ct_open_in filename) (let ((f (ct_open_out filename))) (ct_closef f) (ct_open_in filename))) 'name filename 'current_column 1 'current_line 1 'current_page 1 'status 'open)) ;;;;;;;;;;;;;;; (defun open_for_output (filename) ;;;;;;;;;;;;;;; (ct_make_instance 'ada_output_stream 'real_stream (ct_open_out filename) 'name filename 'current_column 1 'current_line 1 'current_page 1 'status 'open)) ;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream close) () ;;;;;;;;;;;;;;;;;;;;;;;; (setq status 'closed) (ct_closef real_stream)) ;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream close) () ;;;;;;;;;;;;;;;;;;;;;;;;; (setq status 'closed) (ct_closef real_stream)) ;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream delete) () ;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (neq status 'open) (ada_raise '|status_error| "File not open, cannot reset.")) (ct_closef real_stream) (setq status 'closed) (or (errset (ct_deletef name) nil) (ada_raise '|use_error| "File deletion failed."))) ;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream file-delete) () ;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (eq status 'opepn) (ct_closef real_stream)) (or (errset (ct_deletef name) nil) (ada_raise '|use_error| "File deletion failed."))) ;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream delete) () ;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (neq status 'open) (ada_raise '|status_error| "File not open, cannot reset.")) (ct_closef real_stream) (setq status 'closed) (or (errset (ct_deletef name) nil) (ada_raise '|use_error| "File deletion failed."))) ;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream file-delete) () ;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (eq status 'open) (ct_closef real_stream)) (or (errset (ct_deletef name) nil) (ada_raise '|use_error| "File deletion failed."))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Output. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream flush_line_buf) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if line_buf (progn (ct_princ (implode line_buf) real_stream) #+franz (cond ((not (test-stream real_stream)) (drain))) (setq line_buf nil current_column 1)))) (defun flush_out_file () (aip_for (x in **text_file_list**) (when (eq (ct_typep x) 'ada_output_stream)) (do (ct_send x 'flush_line_buf)) )) #| ;;; old code ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream print_string) (string) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This will output any string, breaking it across line/page ;;; boundaries, if necessary. This merely breaks a line into chars, ;;; unfortunately at some expense of consing. (cond ((greaterp max_column 0) (do ((list (list_of_chars string) (cdr list))) ((null list) t) (ct_send self 'print_char (car list)))) (t (do ((list (list_of_chars string) (cdr list))) ((null list) t) (ct_send self 'print_char_no_layout_change (car list))))) #+franz (cond ((not (test-stream real_stream)) (drain)))) |# ;;; ;;; new code -- handle the string directly instead of breaking into chars -AM- ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream print_string) (string) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((strl (exploden string)) (len (ct_string_length string)) (col (plus len current_column)) (limit (add1 max_column)) (more nil)) (cond ((or (zerop max_column) (lessp col limit)) (setq line_buf (nconc line_buf strl) current_column col)) (t (cond ((eq col limit) (ct_princ (implode (nconc line_buf strl)) real_stream) #+franz (cond ((not (test-stream real_stream)) (drain))) (setq line_buf nil current_column 1) (ct_tyo *ada_eol* real_stream)) ((lessp limit col) (setq more (divide_list (difference limit current_column) strl)) (ct_princ (implode (nconc line_buf (car more))) real_stream) #+franz (cond ((not (test-stream real_stream)) (drain))) (setq line_buf (second more) current_column (difference (plus current_column len) max_column)) (ct_tyo *ada_eol* real_stream)) ) (cond ((zerop max_line) (setq current_line (add1 current_line))) ((and (greaterp max_line 0) (eq current_line (1+ max_line))) (ct_tyo *ada_eop* real_stream) (setq current_line 1 current_page (add1 current_page)))) )))) ;;; ;;; new code -- handle the list of chrs directly ;;; instead of breaking into individual chars -AM- ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream print_char_list) (charlist) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((strl charlist) (len (length charlist)) (col (plus len current_column)) (limit (add1 max_column)) (more nil)) (cond ((or (zerop max_column) (lessp col limit)) (setq line_buf (nconc line_buf strl) current_column col)) (t (cond ((eq col limit) (ct_princ (implode (nconc line_buf strl)) real_stream) #+franz (cond ((not (test-stream real_stream)) (drain))) (setq line_buf nil current_column 1) (ct_tyo *ada_eol* real_stream)) ((lessp limit col) (setq more (divide_list (difference limit current_column) strl)) (ct_princ (implode (nconc line_buf (car more))) real_stream) #+franz (cond ((not (test-stream real_stream)) (drain))) (setq line_buf (second more) current_column (difference (plus current_column len) max_column)) (ct_tyo *ada_eol* real_stream)) ) (cond ((zerop max_line) (setq current_line (add1 current_line))) ((and (greaterp max_line 0) (eq current_line (1+ max_line))) (ct_tyo *ada_eop* real_stream) (setq current_line 1 current_page (add1 current_page)))) )))) (defun divide_list (n l) (do ((count n (sub1 count)) (li l (cdr li)) (head nil)) ((or (zerop count) (null li)) (list (nreverse head) li)) (setq head (cons (car li) head)))) ;;; Methods for Output, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Output, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream print_char) (char) ; A fixnum. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Here the real work is done. All characters but the EOx chars are ;;; called printing. These non-printing chars directly reset ;;; current_foo values, and so are treated differently. If a character ;;; is printing, before printing, we check to see if we are at the end ;;; of a line, page, and if so, print EOx chars as necessary, updating ;;; column, line, and page counts. Finally, regardless of char type, it ;;; is printed. (let ((ch_printing t)) (cond ((eq char *ada_eol*) (setq ch_printing nil) (setq current_column 1) (setq current_line (1+ current_line))) ((eq char *ada_eop*) (setq ch_printing nil) (setq current_column 1) (setq current_line 1) (setq current_page (1+ current_page))) ((eq char *ada_eof*) (setq ch_printing nil) (setq current_column 1) (setq current_line 1) (setq current_page 1)) ) (cond (ch_printing (cond ((zerop max_column) (setq current_column (1+ current_column)) (ct_if (is_control_char char) (ct_tyo (map_ascii_to_lispm char) real_stream) (setq line_buf (nconc line_buf (list char))))) ((equal current_column max_column) (ct_if (is_control_char char) (progn (ct_tyo (map_ascii_to_lispm char) real_stream) (ct_princ (implode line_buf) real_stream)) (ct_princ (implode (nconc line_buf (list char))) real_stream)) (setq line_buf nil) (setq current_column (1+ current_column))) ((equal current_column (add1 max_column)) (ct_if (is_control_char char) (ct_tyo (map_ascii_to_lispm char) real_stream)) (setq line_buf (list char)) (ct_tyo *ada_eol* real_stream) (setq current_column 2) (setq current_line (1+ current_line))) (t (setq current_column (1+ current_column)) (ct_if (is_control_char char) (progn (ct_send self 'flush_line_buf) (ct_tyo (map_ascii_to_lispm char) real_stream)) (setq line_buf (nconc line_buf (list char)))))) (cond ((zerop max_line)) ((equal current_line (+ 1 max_line)) ;;?? (ct_tyo *ada_eop* real_stream) (setq current_line 1) (setq current_page (1+ current_page))))) (t (ct_send self 'flush_line_buf) (ct_tyo char real_stream) (ct_if (= current_line (add1 max_line)) (setq current_line 1 current_page (1+ current_page))))) (setq last_out_char char))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream print_char_no_layout_change) (char) ; A fixnum. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Here the real work is done. All characters but the EOx chars are ;;; called printing. These non-printing chars directly reset ;;; current_foo values, and so are treated differently. If a character ;;; is printing, before printing, we check to see if we are at the end ;;; of a line, page, and if so, print EOx chars as necessary,**NOT** updating ;;; column, line, and page counts. Finally, regardless of char type, it ;;; is printed. (setq current_column (1+ current_column)) (setq line_buf (cons char line_buf )) (setq last_out_char char)) ;;; Methods for Output, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Output, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream print_end_of_line) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_send self 'print_char *ada_eol*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream print_end_of_page) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (not (eq last_out_char *ada_eol*)) (ct_send self 'print_char *ada_eol*)) (ct_send self 'print_char *ada_eop*)) ;;; Methods for Output, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Output, continued -- ;;; The following 3 methods return the current column, line, or page of ;;; a stream, but only if that number is a valid Ada integer. If the ;;; number is too big, an exception is raised. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream find_current_column) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (> current_column *ada_max_integer*) (ada_raise '|layout_error| "Column number is too big.") current_column)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream find_current_line) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (> current_line *ada_max_integer*) (ada_raise '|layout_error| "Line number is too big.") current_line)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream find_current_page) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (> current_page *ada_max_integer*) (ada_raise '|layout_error| "Page number is too big.") current_page)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Iutput, continued -- ;;; The following 3 methods return the current column, line, or page of ;;; a stream, but only if that number is a valid Ada integer. If the ;;; number is too big, an exception is raised. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream find_current_column) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (> current_column *ada_max_integer*) (ada_raise '|layout_error| "Column number is too big.") current_column)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream find_current_line) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (> current_line *ada_max_integer*) (ada_raise '|layout_error| "Line number is too big.") current_line)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream find_current_page) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_if (> current_page *ada_max_integer*) (ada_raise '|layout_error| "Page number is too big.") current_page)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Input ;;; Sadly, input requires at least one cons per character read. This is ;;; regrettable, but perhaps can be fixed some day. For now, don't read ;;; in huge files. ;;; ****************************************************** ;;; ** The following functions and methods know about ** ;;; ** the internal structure of a buffer. Only these ** ;;; ** should directly manipulate a buffer. ** ;;; ****************************************************** ;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream peek) (n) ;;;;;;;;;;;;;;;;;;;;;;; ;;; The peek method allows you to look at the nth char not yet read. It ;;; will return 0 if there are no more chars that can be read. If the ;;; internal buffer is empty (or near empty), more characters will be ;;; read. This will return EOL, EOP, EOF chars, which may not be ;;; desirable. Cf. peek-char. (cond (terminal_style_io (ct_tyipeek real_stream)) (t (ct_if (< (length input_buffer) n) (ct_send self 'refill_buffer n)) (ct_nth n input_buffer)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream peek_char) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This method will peek like peek, but will only return valid chars. (let ((ch (ct_send self 'peek 1))) (ct_if (or (eq ch *ada_eol*) (eq ch *ada_eop*)) (ct_if (eq (ct_send self 'peek 2) *ada_eop*) (ct_send self 'peek 3) (ct_send self 'peek 2)) ch))) ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream refill_buffer) (n) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This will read in n more characters if possible, restocking the ;;; input buffer. If the end of file (physical) is reached, ;;; true_end_of_file is set true. If we have terminal_style_io, we ;;; never have more than one character in the buffer at a time. (cond ((not terminal_style_io) (do ((i 0 (1+ i))) ((= i n)) (let ((ch (ct_tyi real_stream 'eof))) (ct_if (or (eq ch 'eof) (eq ch *ada_eof*)) (setq true_end_of_file t)) (setq input_buffer (nconc input_buffer (list ch))))) (ct_if true_end_of_file (setq input_buffer (nconc input_buffer (zeroes n))))))) ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream get_char) () ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Gets one printing character from the input stream. (prog (next) (ct_if (< (length input_buffer) 4) (ct_send self 'refill_buffer 10)) loop (setq next (ct_send self 'peek 1)) (cond ((null next) (ada_raise '|end_error| "No more characters.")) ((eq next *ada_eol*) (setq current_column 1 current_line (1+ current_line)) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (go loop)) ((eq next *ada_eop*) (setq current_line 1 current_page (1+ current_page)) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (go loop)) ((or (eq next *ada_eof*) (and terminal_style_io (member next *keyboard_eof*))) (ada_raise '|end_error| "EOF character found.")) ((eq next 'eof) (ada_raise '|end_error| "EOF character found.")) ((is_control_char next) (ada_raise '|data_error| "illegal character"))) (ct_if terminal_style_io ;;Remove the character we (ct_tyi real_stream) ;;just peeked at. (setq input_buffer (remove_first input_buffer))) (setq current_column (1+ current_column)) (return next))) ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream get_char_any) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Same as get_char, but returns eol & eop characters, too. (prog (next) (ct_if (< (length input_buffer) 4) (ct_send self 'refill_buffer 10)) loop (setq next (ct_send self 'peek 1)) (cond ((null next) (ada_raise '|end_error| "No more characters.")) ((eq next *ada_eol*) (setq current_column 1 current_line (1+ current_line)) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (return next)) ((eq next *ada_eop*) (setq current_line 1 current_page (1+ current_page)) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (return next)) ((or (eq next *ada_eof*) (and terminal_style_io (member next *keyboard_eof*))) (ada_raise '|end_error| "EOF character found.")) ((or (eq next 'eof) (and terminal_style_io (member next *keyboard_eof*))) (ada_raise '|end_error| "EOF Character found.")) ((is_control_char next) (ada_raise '|data_error| "illegal character"))) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (setq current_column (1+ current_column)) (return next))) ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream get_char_no_eof) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Same as get_char, but returns char 0 on eof so fsm won't break. (prog (next count) ; add count to diffentiate the Leading line terminator ; and the Real Line terminator (setq count 0) (ct_if (< (length input_buffer) 4) (ct_send self 'refill_buffer 10)) loop (setq next (ct_send self 'peek 1)) (cond ((null next) (return *ada_eof*)) ; If no more chars. ((eq next *ada_eol*) (setq current_column 1 current_line (1+ current_line)) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (go loop)) ((eq next *ada_eop*) (setq current_line 1 current_page (1+ current_page)) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (go loop)) ((eq next *ada_eof*) (return *ada_eof*)) ((eq next 'eof) (return *ada_eof*)) ((is_control_char next) (ada_raise '|data_error| "illegal character"))) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (setq current_column (1+ current_column)) (return next))) ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream get_char_any_no_eof) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Same as get_char, but returns eol , eop & eof characters, too. (prog (next) (ct_if (< (length input_buffer) 4) (ct_send self 'refill_buffer 10)) loop (setq next (ct_send self 'peek 1)) (cond ((null next) (ada_raise '|end_error| "No more characters.")) ((eq next *ada_eol*) (setq current_column 1 current_line (1+ current_line)) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (return next)) ((eq next *ada_eop*) (setq current_line 1 current_page (1+ current_page)) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (return next)) ((eq next *ada_eof*) (return *ada_eof*)) ((eq next 'eof) (return *ada_eof*)) ((is_control_char next) (ada_raise '|data_error| "illegal character"))) (ct_if terminal_style_io (ct_tyi real_stream) (setq input_buffer (remove_first input_buffer))) (setq current_column (1+ current_column)) (return next))) ;;; Methods for Input, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Methods for Input, continued -- ;;;;;;;;;;;; (defun remove_first (list) ; Knows that a buffer is a list. ;;;;;;;;;;;; (cdr list)) ;;; ************************************************************ ;;; ** The preceeding functions and methods know about ** ;;; ** the internal structure of a buffer. Only these ** ;;; ** should directly manipulate a buffer. Place all such ** ;;; ** functions and methods between these two moby comments. ** ;;; ************************************************************ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream end_of_line_p) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Checks for the end of a line. (let ((next (ct_send self 'peek 1))) (or (eq next *ada_eol*) (eq next *ada_eof*))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream end_of_page_p) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((next (ct_send self 'peek 1))) (or (eq next *ada_eof*) (and (eq next *ada_eol*) (eq (ct_send self 'peek 2) *ada_eop*))))) (defun peek_ignore_return (stream) (do ((char (ct_send stream 'ct_tyipeek) (ct_send stream 'ct_tyipeek))) ((not (equal char #\return)) char) (ct_send stream 'ct_tyi) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream end_of_file_p) () ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (cond (terminal_style_io (let ((next #+lispm (peek_ignore_return real_stream) #+franz (ct_tyi real_stream))) (cond ((member next *keyboard_eof*) t) ((member next '(#\line *ada_eol*)) (cond ((member (setq next #+franz (ct_tyi real_stream) #+lispm (ct_send real_stream 'ct_tyipeek)) '(*ada_eol* *ada_eop*)) (cond ((member (setq next #+franz (ct_tyi real_stream) #+lispm (ct_send real_stream 'ct_tyipeek) ;;(funcall real_stream ':tyi) ) *keyboard_eof*) t) )) )) (t nil)))) (t (let ((next (ct_send self 'peek 1)) (next2 (ct_send self 'peek 2))) (or (eq next *ada_eof*) (null next) (eq next 'eof) (and (eq next *ada_eol*) (eq next2 'eof)) ; for put_line (zerop next) (and (eq next *ada_eol*) (eq next2 *ada_eop*) (eq (ct_send self 'peek 3) *ada_eof*)))) ) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO Methods for Strings and Lines. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream get_string) (n) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This will read a string of N characters from the input stream, ;;; ignoring eol & eop characters. (let ((string "")) (ct_dotimes n (setq string (ct_string_append string (ct_send self 'get_char)))) string)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream skip_line) (n) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ada_Skip_Line: "Reads and discards all characters until a line ;;; terminator has been read, and then sets the current column number to ;;; one. If the line terminator is not immediately followed by a page ;;; terminator, the current line number is incremented. Otherwise, if ;;; the line terminator is immediately followed by a page terminator, ;;; then the page terminator is skipped, the current page number is ;;; incremented by one, and the current line number is set to one." If ;;; the spacing N is greater than one, the above is done N times. Works ;;; on in_files only. (ct_dotimes n (prog (ch) loop (setq ch (ct_send self 'get_char_any)) ; Read a char. (ct_if (not (eq ch *ada_eol*)) (go loop)) ; If not eol, go back for more. (ct_if (eq (ct_send self 'peek 1) *ada_eop*) ; If next ch is eop, (ct_send self 'get_char))))); then read it too. ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream skip_page) (n) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ada_skip_page. reads and discards all characters and line terminators ;;; until a page terminator has been read. Then adds one to the current page ;;; number, and sets the current column and line numbers to one. (ct_dotimes n (prog (ch) loop (setq ch (ct_send self 'get_char_any)) ; Read a char. (ct_if (not (eq ch *ada_eop*)) (go loop)) ; If not eol, go back for more. ))) ;;; IO Methods for Strings and Lines, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO Methods for Strings and Lines, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream get_line) (n) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Reads characters until the end of line, accumulating into a string. ;;; May return 0 characters if already at end of line. Will also stop ;;; if n chars are read. (let ((string nil) ch) (do ((cnt 0 (add1 cnt)) (stop nil)) ((or stop (eq n cnt))) (setq ch (ct_send self 'get_char_any_no_eof)) (ct_if (or (eq ch *ada_eol*) (eq ch *ada_eof*)) (setq stop t) (setq string (cons ch string)))) (nreverse string))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO Methods For Integers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream get_integer) (width) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Get_integer will read up to width characters (or unbounded, if ;;; width=0), and return an integer in the range range. If the ;;; integer read falls outside the range, data_error is raised. ;;; Take out the range argument, because the constraint error will be ;;; raised before reach this point. ++AM++ (let ((num (ct_send self 'fsm *integer_table* width))) num)) ;; (ct_if (<= (first range) num (second range)) ;; num ;; (ada_raise '|data_error| ;; "Integer out of range.")))) ;; ;;; IO Methods For Integers, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO Methods For Integers, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream put_integer) (integer width ebase) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Put_integer must be able to print integers in any base from 2 to 16. #+lispm ;This version probably will not (let (list basen (base 10.) (ibase 10.) ;work on Franz since it counts on (intl (exploden integer))) ;binding the specvar, base. (cond ((= ebase 10.) (setq list (nbutlast intl))) (t (setq basen (exploden ebase) list (fix_hex_chars (nconc (butlast basen) '(35) (let ((base ebase)) intl) '(35)))))) (ct_send self 'print_char_list (ct_if (< (length list) width) (nconc (firstn (- width (length list)) (circular-list *ada_space*)) list) list)) ) #+franz ;This version would work on both (let (list (neg nil)) ;machines, but it is inefficient. (ct_if (< integer 0) (setq integer (- integer) neg t)) (setq list (do ((num integer) (rems (ct_if (not (= ebase 10)) (list #/#) nil))) ((< num ebase) (fix_hex_chars (cons (plus #/0 num) rems))) (setq rems (cons (plus #/0 (mod num ebase)) rems)) (setq num (*quo num ebase)))) (ct_if neg (setq list (cons #/- list))) (ct_if (not (= ebase 10)) (setq list (nconc (exploden ebase) (list #/#) list))) (ct_send self 'print_char_list (ct_if (< (length list) width) (nconc (firstn (- width (length list)) (circular-list *ada_space*)) list) list)) ) ) ;; (cond ((not (test-stream real_stream)) (drain)))) ;; flush the output buffer for ;; terminal. ;;; IO Methods For Integers, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO Methods For Integers, continued -- (defun fix_hex_chars (list) ;;; This will change the characters #/: through #/? to #/A to #/F. ;;; This is necessary, since A through F do not immediately follow ;;; the characters 0 through 9 in the ASCII sequence. #+lispm (loop for char in list collecting (ct_if (<= #/: char #/?) (plus char (- #/A #/:)) char)) #+franz (progn (do ((l list (cdr l))) ((null l) t) (ct_if (<= #/: (car l) #/?) (rplaca l (plus (car l) (- #/A #/:))))) list) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO Methods for Real Numbers -- ;;; The the range argument been taken out by ++AM++ ;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream get_real) (width) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Get_real will read up to width characters (or unbounded, if width = ;;; 0) and return a real in the range range. (If the real is outside ;;; of the range, data_error is raised.) (let ((num (ct_send self 'fsm *real_table* width))) num)) ;; (ct_if (<= (first range) num (second range)) ;; num ;; (ada_raise '|data_error| "Real Number out of range.")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream put_real) (number fore aft exp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Outputting a real number, even in just base 10, is no easy task. ;;; If an exponent is desired, we have to normalize the number to the ;;; range (1.0 9.999) and if no exponent is desired, none can be ;;; printed. (let ((*nopoint t)) (ct_if (zerop exp) (ct_send self 'print_char_list (real_charl_sans_exp number fore aft)) (ct_send self 'print_char_list (real_charl number fore aft exp))))) ;;; IO Methods for Real Numbers, cont'd -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO Methods for Real Numbers, cont'd -- ;;;;;;;;;;;;;;;;;;;; (defun real_charl_sans_exp (num for aft) ;;;;;;;;;;;;;;;;;;;; (let ((number (cond ((= (abs num) 0.0) 0.0) (t (plus (abs num) (expt 10.0 (minus (add1 aft)))))))) (ct_if (< num 0) (real_charl_no_exp number for aft t) (real_charl_no_exp number for aft nil)))) ;;;;;;;;;;;;;;;;;; (defun real_charl_no_exp (number fore aft negative) ;;;;;;;;;;;;;;;;;; ;;; This returns a string of characters representing the number (in ;;; base 10) with no exponent. (let ((*nopoint t) (int (ct_if negative (cons #/- (exploden (int_part number))) (exploden (int_part number)))) (frac (frac_part (abs number) aft))) (nconc (pad_left_charl int fore #\space) (cons #/. frac )))) ;;; IO Methods for Real Numbers, cont'd -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO Methods for Real Numbers, cont'd -- ;;;;;;;;;;; (defun real_charl (number fore aft exp) ;;;;;;;;;;; ;;; This returns a string of characters representing the number (in ;;; base 10.) with an exponent. The number is normalized. (let (ans (neg nil) (*nopoint t)) (ct_if (< number 0.0) (setq number (minus number) neg t)) (cond ((>= number 10.0) (setq ans (scale_down number))) ((< number 1.0) (setq ans (scale_up number))) (t (setq ans (list number 0)))) (nconc (real_charl_no_exp (cond ((= number 0.0) 0.0) (t (plus (expt 10.0 (minus (add1 aft))) (first ans)))) fore aft neg) (exponent (second ans) exp)))) ;;;;;;;;;; (defun scale_down (number) ;;;;;;;;;; ;;; Returns a list of a number and an exponent. The number expected ;;; is more than 10., so we get results by dividing. (do ((num number (quotient num 10.0)) (exp 0 (1+ exp))) ((< num 10.0) (list num exp)))) ;;;;;;;; (defun scale_up (number) ;;;;;;;; (ct_if (zerop number) (list 0.0 0) (do ((num number (times num 10.0)) (exp 0 (1- exp))) ((>= num 1.0) (list num exp))))) ;;; IO Methods for Real Numbers, cont'd -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO Methods for Real Numbers, cont'd -- ;;;;;;;; (defun exponent (value size) ; Returns chlist to represent expnt. ;;;;;;;; (ct_if (< value 0) (nconc (list #/E #/-) (pad_left_charl (exploden (int_part (minus value))) (sub1 size) #/0)) (cons #/E (pad_left_charl (exploden (int_part value)) size #/0)))) ;;;;;;;; (defun int_part (number) ; Extracts string of integer part. ;;;;;;;; (let ((*nopoint t)) (fix number))) ;;;;;;;; (defun pad_left_str (string n char) ; Pads string on left to make it ;;;;;;;; ; at least N chars long, with char. (let ((str (exploden string))) (ct_if (< (length str) n) (maknam (append (firstn (- n (length str)) (circular-list char)) str)) string))) ;;;;;;;;; (defun pad_right_str (string n char) ;;;;;;;;; (let ((str (exploden string))) (ct_if (< (length str) n) (maknam (append str (firstn (- n (length str)) (circular-list char)))) string))) (defun pad_left_charl (chlist n char) (let ((len (length chlist))) (ct_if (< len n) (nconc (firstn (- n len) (circular-list char)) chlist) chlist))) (defun pad_right_charl (chlist n char) (let ((len (length chlist))) (ct_if (< len n) (nconc chlist (firstn (- n len) (circular-list char))) chlist))) ;;; IO Methods for Real Numbers, cont'd -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO Methods for Real Numbers, cont'd -- ;;;;;;;;; (defun frac_part (number aft) ; Extracts the chars of the ;;;;;;;;; ; fractional portion of number. (let* ((chlist nil) (base 10.) (ibase 10.) (numl (frac_char_list number aft))) (cond ((greaterp (length numl) aft) (car (divide_list aft numl))) (t (pad_right_charl numl aft #/0))) )) (defun frac_char_list (number aft) (let* ((no (difference number (fix number))) (numlist (cddr (exploden no))) (numl (ct_if (or (member #/e numlist) (member #/E numlist)) (do ((ans nil) (num (times no 10.0) (times num 10.0)) (n 0 (add1 n))) ((>= n aft) (nreverse ans)) (setq ans (cons (ct_if (> num 1.0) (car (exploden num)) #/0 ) ans))) numlist))) numl)) ;;;;;; (defun frac (number) ; Returns the fractional portion. ;;;;;; (difference number (fix number))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; IO for Enumerated Types (setq *item_chars* '(#/a #/b #/c #/d #/e #/f #/g #/h #/i #/j #/k #/l #/m #/n #/o #/p #/q #/r #/s #/t #/u #/v #/w #/x #/y #/z #/A #/B #/C #/D #/E #/F #/G #/H #/I #/J #/K #/L #/M #/N #/O #/P #/Q #/R #/S #/T #/U #/V #/W #/X #/Y #/Z #/_ #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9 #/0)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_output_stream put_enum) (chlist width lc) ; Prints out an ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; enumerated item. (let ((len (length chlist)) (charlist (ct_if lc (ct_charl_downcase chlist) (ct_charl_upcase chlist)))) (ct_send self 'print_char_list (ct_if (neq width 0) (cond ((eq len width) charlist) ((lessp len width) (pad_left_charl charlist width *ada_space*)) (t (car (divide_list width charlist)))) charlist)))) (defun ct_charl_downcase (chlist) (do ((l chlist (cdr l)) (ans nil)) ((null l) (nreverse ans)) (ct_if (<= #/A (car l) #/Z) (setq ans (cons (plus #/a (difference (car l) #/A)) ans)) (setq ans (cons (car l) ans))) )) (defun ct_charl_upcase (chlist) (do ((l chlist (cdr l)) (ans nil)) ((null l) (nreverse ans)) (ct_if (<= #/a (car l) #/z) (setq ans (cons (plus #/A (difference (car l) #/a)) ans)) (setq ans (cons (car l) ans))) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream get_enum) (values) ;;;;;;;;;;;;;;;;;;;;;;;;;;; (prog (string ch ans) (setq string "") loop1 (setq ch (ct_send self 'get_char_any_no_eof)) (ct_if (or (eq ch *ada_space*) (eq ch *ada_eol*) (eq ch *ada_eop*)) (go loop1)) loop2 (setq string (ct_string_append string ch)) (setq ch (ct_send self 'get_char_any_no_eof)) (ct_if (memq ch *item_chars*) (go loop2)) (setq ans (implode (exploden (ct_string_downcase string)))) (ct_if (memq ans values) (return ans) (ada_raise '|data_error| "Item not in data range.")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Finite State Machine ;;; In order to easily read different kinds of things, we have a simple ;;; finite state machine (table driven) that will allow things to be ;;; read from a file. The FSM message sent to a file expects a table ;;; as input. It returns a number, or raises data_error if an illegal ;;; character is read. ;;; The table is formatted as an a-list of a-lists. The grand alist ;;; has STATES as the accessor, and a sub-alist as a value. Each ;;; sub-alist uses CHARACTERS as the accessor, and has states as ;;; values. The character accessors are actually LISTS of characters, ;;; and (ass 'memq) is done to see if the character in question is any ;;; one of the proposed chars. (Thus we don't have to have 128 ;;; different entries in each sublist.) ;;; The following states are special. START: the initial state. ;;; Nothing funny happens here, but it seems special anyway. ERROR: ;;; if this state is stumbled across, the FSM halts, and DATA_ERROR is ;;; raised immediately. FINAL: The character that caused entry of ;;; this state is not read (we just peeked at it), and the number read ;;; so far is returned. Also, if after reading width characters, we ;;; are in an accepting state, we return a number. An accepting state ;;; is any state which represents a valid number built so far, but ;;; which could have more digits (or features) added. If width is 0, ;;; no character limits are imposed. ;;;;;;;;;;;;;;;;;;;;;; (ct_defmethod (ada_input_stream fsm) (table width) ;;;;;;;;;;;;;;;;;;;;;; (fsm table width self)) ;;; Next are the character definitions for the finite state machine. (setq *digits* '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)) (setq *baser* '(#/# #/:)) (setq *signs* '(#/+ #/-)) (setq *spaces* `(,*ada_space* )) (setq *underscore* '(#/_)) (setq *extended* '(#/a #/b #/c #/d #/e #/f #/A #/B #/C #/D #/E #/F #/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9)) ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Finite State Machine, continued -- (setq *exp_start* '(#/E #/e)) (setq *exp_sign_int* '(#/+)) (setq *exp_sign_real* '(#/+ #/-)) (setq *radix_point* '(#/.)) (setq *else* ;;; Note that *else* is just defined to be all characters, so it works ;;; everywhere, since it is tested last. '(32. 33. 34. 35. 36. 37. 38. 39. 40. 41. 42. 43. 44. 45. 46. 49. 50. 51. 52. 53. 54. 55. 56. 57. 58. 59. 60. 61. 62. 63. 64. 65. 66. 67. 68. 69. 70. 71. 72. 73. 74. 75. 75. 77. 78. 79. 80. 81. 82. 83. 84. 85. 86. 87. 88. 89. 90. 91. 92. 93. 94. 95. 96. 97. 98. 99. 100. 101. 102. 103. 104. 105. 106. 107. 108. 109. 110. 111. 112. 113. 114. 115. 116. 117. 118. 119. 120. 121. 122. 123. 124. 125. 126. 127. 128. 140. 10. 13. #\return)) (setq *int_error* ;;; Note that *int_error* is just defined to be all characters, so it works ;;; everywhere, since it is tested last. '( 33. 34. 35. 36. 37. 38. 39. 40. 41. 42. 43. 44. 45. 46. 49. 50. 51. 52. 53. 54. 55. 56. 57. 58. 59. 60. 61. 62. 63. 64. 65. 66. 67. 68. 69. 70. 71. 72. 73. 74. 75. 75. 77. 78. 79. 80. 81. 82. 83. 84. 85. 86. 87. 88. 89. 90. 91. 92. 93. 94. 95. 96. 97. 98. 99. 100. 101. 102. 103. 104. 105. 106. 107. 108. 109. 110. 111. 112. 113. 114. 115. 116. 117. 118. 119. 120. 121. 122. 123. 124. 125. 126. 127. 128. #+lispm 10. #+franz 13. )) (setq *delimiter* '(#\space #+lispm #\return #+franz 10 #\linefeed)) ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;; (setq *integer_table* ;;;;;;;;;;;;;;; '((start . ((*digits* . state1) (*spaces* . start) (*signs* . sign) (*else* . error))) (sign . ((*digits* . state1) (*else* . error))) (state1 . ((*digits* . state1) (*underscore* . state2) (*baser* . state3) (*exp_start* . state4) (*int_error* . error) (*delimiter* . final))) (state2 . ((*digits* . state1) (*else* . error))) (state3 . ((*extended* . state5) (*else* . error))) (state4 . ((*digits* . state8) (*exp_sign_int* . state9) (*else* . error))) (state5 . ((*extended* . state5) (*underscore* . state6) (*baser* . state7) (*else* . error))) (state6 . ((*extended* . state5) (*else* . error))) (state7 . ((*exp_start* . state4) (*else* . final))) (state8 . ((*digits* . state8) (*underscore* . state10) (*else* . final))) (state9 . ((*digits* . state8) (*else* . error))) (state10 . ((*digits* . state8) (*else* . error))))) ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Finite State Machine, continued -- ;;;;;;;;;;;; (setq *real_table* ;;;;;;;;;;;; '((start . ((*spaces* . start) (*signs* . state36) (*digits* . state20) (*else* . error))) (state20 . ((*underscore* . state21) (*digits* . state20) (*baser* . state22) (*radix_point* . state29) (*else* . error))) (state21 . ((*digits* . state20) (*else* . error))) (state22 . ((*extended* . state23) (*else* . error))) (state23 . ((*extended* . state23) (*radix_point* . state25) (*underscore* . state24) (*else* . error))) (state24 . ((*extended* . state23) (*else* . error))) (state25 . ((*extended* . state26) (*else* . error))) (state26 . ((*extended* . state26) (*baser* . state28) (*underscore* . state27) (*else* . error))) (state27 . ((*extended* . state26) (*else* . error))) (state28 . ((*exp_start* . state32) (*else* . final))) (state29 . ((*digits* . state30) (*else* . error))) (state30 . ((*digits* . state30) (*exp_start* . state32) (*underscore* . state31) (*else* . final))) (state31 . ((*digits* . state30) (*else* . error))) (state32 . ((*digits* . state34) (*exp_sign_real* . state33) (*else* . error))) (state33 . ((*digits* . state34) (*else* . error))) (state34 . ((*digits* . state34) (*underscore* . state35) (*else* . final))) (state35 . ((*digits* . state34) (*else* . error))) (state36 . ((*digits* . state20) (*else* . error))))) ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;; (setq *accept_states* '(state1 state7 state8 state30 state28 state34)) ;;;;;;;;;;;;;;; ;;;;;;;;; (setq *actions* ;;;;;;;;; '((start . nil) (sign . adjust_sign) (state1 . accum_into_int) (state2 . nil) (state3 . make_base_from_int) (state4 . init_expt) (state5 . accum_into_int) (state6 . nil) (state7 . nil) (state8 . accum_into_exp) (state9 . nil) (state10 . nil) (state20 . accum_into_int) (state21 . nil) (state22 . make_base_from_int) (state23 . accum_into_int) (state24 . nil) (state25 . start_fraction) (state26 . accum_into_frac) (state27 . nil) (state28 . nil) (state29 . start_fraction) (state30 . accum_into_frac) (state31 . nil) (state32 . init_expt) (state33 . adjust_expt_sign) (state34 . accum_into_exp) (state35 . nil) (state36 . adjust_sign))) ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Finite State Machine, continued -- ;;;;; (defun fsm (table width instance) ;;;;; (prog (state count ch firstrun base_literal) (setq state 'start count 1 firstrun t) (setq *fsm_number* 0 ;value of number *fsm_exp* nil ;value of exponent *fsm_base* 10. ;base of number *fsm_sign* 1. ;sign of number *fsm_exp_sign* 1. ;sign of exponent *fsm_radix* nil) ;# of digits past radix point ;;(setq *io_get_integer* t) loop ;;(setq ch (ct_send instance 'get_char_any_no_eof)) ; look at next char. (setq ch (ct_send instance 'peek 1)) ; look at next char. ;;ignore the leding space eol and eop if width is 0 (ct_if firstrun (CT_IF (= width 0) (cond ((memq ch `(,*ada_space* ,*ada_eol* ,*ada_eop*)) (setq ch (ct_send instance 'get_char_any_no_eof)) (go loop)) (t (setq firstrun nil))) (cond ((memq ch `(,*ada_space* ,*ada_eol* ,*ada_eop*)) (setq ch (ct_send instance 'get_char_any_no_eof)) (setq count (1+ count)) (go loop)) (t (setq firstrun nil)) ) )) (ct_if (member ch '(eof *ada_eof*)) (ct_if (memq state *accept_states*) (return (fsm_value)) (ada_raise '|end_error| "End of file in middle of parsing number."))) (ct_if (and (< count width) (eq ch *ada_space*)) (ada_raise '|data_error| "blank space encountered in the middle")) (ct_if (memq ch *baser*) (cond ((null base_literal) (setq base_literal ch)) ((not (eq base_literal ch)) (ada_raise '|data_error| "the base literal is inconsistent")) )) (setq state (cdr (ass 'memquux ch (cdr (assq state table))))) (cond ((eq state 'final) (return (fsm_value))) ((eq state 'error) (ada_raise '|data_error| "Offending character read.")) (t (and (cdr (assq state *actions*)) ; If there is a state-fun, (eval (list (cdr (assq state *actions*)); take that action. ch))) (setq count (1+ count)) )) ; discard character (setq ch (ct_send instance 'get_char_any_no_eof)) ; If we read too many characters, either return a number, or ; raise an error. (cond ((neq width 0) (ct_if (= count (1+ WIDTH)) (ct_if (memq state *accept_states*) (return (fsm_value)) (ada_raise '|data_error| "Too many chars read."))))) (go loop))) ;;; ;;; str_fsm -- read the ada number from the string ;;; (defun str_fsm (table str) (prog (state count ch firstrun) (setq state 'start count 1 firstrun t) (setq *fsm_number* 0 ;value of number *fsm_exp* nil ;value of exponent *fsm_base* 10. ;base of number *fsm_sign* 1. ;sign of number *fsm_exp_sign* 1. ;sign of exponent *fsm_radix* nil) ;# of digits past radix point loop (setq ch (car str) str (cdr str)) ; look at next char. ;;ignore the leding space eol and eop (ct_if firstrun (cond ((memq ch `(,*ada_space* ,*ada_eol* ,*ada_eop*)) (go loop)) (t (setq firstrun nil)))) (ct_if (null str) (ct_if (memq state *accept_states*) (return (fsm_value)) (ada_raise '|end_error| "End of file in middle of parsing number."))) (setq state (cdr (ass 'memquux ch (cdr (assq state table))))) (cond ((eq state 'final) (return (fsm_value))) ((eq state 'error) (ct_if *in_attribute_value* (ada_raise '|constraint_error| "Offending character read.") (ada_raise '|data_error| "Offending character read."))) (t (and (cdr (assq state *actions*)) ; If there is a state-fun, (eval (list (cdr (assq state *actions*)); take that action. ch))) (setq count (1+ count)) )) ; discard character (go loop))) ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Finite State Machine, continued -- ;;;;;;;;;; ; Similar to fsm. (defun string_fsm (table string) ; Returns a number and a count ;;;;;;;;;; ; of how many chars were read. (prog (state index width ch) (setq state 'start index -1 width (ct_string_length string)) (setq *fsm_number* 0 ;value of number *fsm_exp* nil ;value of exponent *fsm_base* 10. ;base of number *fsm_sign* 1. ;sign of number *fsm_exp_sign* 1. ;sign of exponent *fsm_radix* nil) ;# of digits past radix point loop (setq index (1+ index) ch (ct_nth_char string index)) ; look at next char. (setq state (cdr (ass 'memquux ch (cdr (assq state table))))) (cond ((eq state 'final) (return (list (fsm_value) index))) ((eq state 'error) (ada_raise '|data_error| "Illegal character read.")) (t (and (cdr (assq state *actions*)) ;If there is a state-fun, (eval (list (cdr (assq state *actions*)); take that action. ch))))) ; If we read too many characters, either return a number, or ; raise an error. (ct_if (= index (1- width)) (ct_if (memq state *accept_states*) (return (list (fsm_value) index)) (ada_raise '|data_error| "Too many chars read."))) (go loop))) ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Finite State Machine, continued -- ;;;;;;; (defun memquux (char atom) ;;;;;;; (memq char (symeval atom))) ;;;;;;;;; (defun fsm_value () ;;;;;;;;; (ct_if *fsm_exp* (times *fsm_number* *fsm_sign* (expt (float *fsm_base*) (* *fsm_exp_sign* *fsm_exp*))) (times *fsm_number* *fsm_sign*))) ;;;;;;;;;;;;;; (defun start_fraction (ch) ; Turns *fsm_radix* into 1/base. ;;;;;;;;;;;;;; (progn ch ; Ignored (setq *fsm_radix* (quotient 1.0 (float *fsm_base*))))) (defun accum_into_frac (ch) ;;; Accumulates the current digit as part of a fraction by multiplying ;;; the value of the digit by the current radix. (In base 10, the ;;; radix starts at .1 and progresses .01 .001 .0001, ...) This number ;;; is added into the accumulating number. (setq *fsm_number* (plus *fsm_number* (times (digit_value ch) *fsm_radix*)) *fsm_radix* (quotient *fsm_radix* *fsm_base*))) ;;;;;;;;;;; (defun adjust_sign (ch) ; Sets the sign correctly. ;;;;;;;;;;; (ct_if (eq ch #/-) (setq *fsm_sign* -1.))) ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Finite State Machine, continued -- ;;;;;;;;;;;;;;;; (defun adjust_expt_sign (ch) ; Sets exponent sign correctly. ;;;;;;;;;;;;;;;; (ct_if (eq ch #/-) (setq *fsm_exp_sign* -1.))) ;;;;;;;;;;;;;; (defun accum_into_int (ch) ; Accumulates the current digit ;;;;;;;;;;;;;; ; into the number being built. (ct_if (zerop *fsm_number*) (setq *fsm_number* (digit_value ch)) (setq *fsm_number* (plus (times *fsm_number* *fsm_base*) (digit_value ch))))) ;;;;;;;;;;;;;;;;;; ; Sets the base to what number (defun make_base_from_int (ch) ; has been built, and resets ;;;;;;;;;;;;;;;;;; ; the number. (progn ch ; Ignored. (ct_if (or (> *fsm_number* 16.) (< *fsm_number* 2.)) (ada_raise '|data_error| "Base is out of range 2. < b < 16.") (setq *fsm_base* *fsm_number* *fsm_number* 0)))) ;;;;;;;;; (defun init_expt (ch) ; Sets the exponent to 0. ;;;;;;;;; (progn ch ; Ignored. (setq *fsm_exp* 0))) ;;;;;;;;;;;;;; (defun accum_into_exp (ch) ; Accumulates into the exponent. ;;;;;;;;;;;;;; (ct_if (zerop *fsm_exp*) (setq *fsm_exp* (digit_value ch)) (setq *fsm_exp* (plus (times *fsm_exp* 10.) (digit_value ch))))) ;;;;;;;;;;; (defun digit_value (ch) ;;;;;;;;;;; (cond ((and (<= ch #/9) (>= ch #/0)) (- ch #/0)) ((and (<= ch #/F) (>= ch #/A)) (- ch #/A -10.)) (t (- ch #/a -10.)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Macros -- ;;; This next should be moved to AIP, since it is of general utility. ++mlm ;;;;;; (defun zeroes (n) ; Returns a list of n zeroes. ;;;;;; (firstn n (circular-list 0))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; eof ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;