;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- ;;; $Header: /ct/interp/interp.l,v 1.91 85/06/25 11:21:13 bill Exp $ ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; INTERP ;;; ;;; ;;; ;;; The Computer * Thought Corporation Ada Interpreter, Main File. ;;; ;;; ;;; ;;; Paul Robertson and Mark Miller. 8-Feb-83 ;;; ;;; See last page for edit history. ;;; ;;; ;;; ;;; This file provides the interface between front and back ends, as ;;; ;;; well as the interface to the rest of the Ada * Tutor, and/or the ;;; ;;; outside world, when the interpreter is used standalone. ;;; ;;; ;;; ;;; Note: "Ada" is a registered trademark of the US Department of ;;; ;;; Defense. This interpreter will be submitted to the AJPO for ;;; ;;; validation by 1Q84. ;;; ;;; ;;; ;;; Written by Paul Robertson and Mark Miller, with much help from ;;; ;;; our colleagues at C*T. The Ada Tutor is a proprietary software ;;; ;;; project of Computer * Thought Corporation. Source code and doc- ;;; ;;; umentation describing implementation details are available on a ;;; ;;; confidential, non-disclosure basis only. These materials, and ;;; ;;; this file in particular, are trade secret documents of C*T Corp. ;;; ;;; ;;; ;;; (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. ;;; ;;; Robertson & Miller, 1982. C*T Diana Virtual Machine Spec. ;;; ;;; {See "ctvax:/mnt/mark/backend/dvm-spec.txt"} ;;; ;;; Evans et al. (Tartan Labs), October 1982. ;;; ;;; Draft Revised Diana Ref. Man. ;;; ;;; US AJPO, etc., July 1982. Ada Language Reference Manual [LRM] ;;; ;;; (Draft Mil-Std 1815). ;;; ;;; The following code assumes familiarity with these materials. ;;; ;;; ;;; ;;; ASSUMES CT_LOAD AND SUITABLE FILEMAP ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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 'ctio)) ;the new io pkg. (eval-when (compile load eval) (ct_load 'time)) ;Timing functions. (eval-when (compile load eval) (ct_load 'ferec)) ;;; The Front End system consists of three major components: ;;; The Lexical Analyser, The Parser, and the Static Semantics. ;;; There are several other files as well, such as shared declarations (eval-when (compile load eval) (ct_load 'stdenv)) ; the standard env. (eval-when (compile load eval) (ct_load 'adas)) (eval-when (compile load eval) (ct_load 'protect)) (eval-when (compile load eval) (ct_load 'eror)) (eval-when (compile load eval) (ct_load 'lana)) ;Lexical Analyzer. (eval-when (compile load eval) (ct_load 'pser)) ;Parser. (eval-when (compile load eval) (ct_load 'sema)) ;Static Semantics. ;;; The Back End system consists of three major components: ;;; The abstract datatype Diana, the back end Driver and ;;; associated macros, and the Dynamic Semantic Functions. (eval-when (compile load eval) (ct_load 'diana)) ;Diana Datatype. (eval-when (compile load eval) (ct_load 'driver)) ;Backend Driver. (eval-when (compile load eval) (ct_load 'textiol)) ; the fun to load ; the package text_io (eval-when (compile load eval) (ct_load 'seqiol)) (eval-when (compile load eval) (ct_load 'diriol)) (eval-when (compile load eval) (ct_load 'calendl)) (eval-when (compile load eval) (ct_load 'dynsem)) ;Dynamic Semantics. (eval-when (compile load eval) (ct_load 'dsmacs)) ;DS_macros (eval-when (compile load eval) (ct_load 'ctadadt)) ;Ada datatypes ;;; Possibly the next file should be merged into here, too? ++mlm (eval-when (compile load eval) (ct_load 'incd)) ;interface be/fe. (eval-when (compile load eval) (ct_load 'dianaio)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- (declare (ct_includef 'intrpdcl)) ;;Get all Interp Declarations. ;Computed by effect and remembered across wrenching of BE calls. (declare (special *di_out* *di_in* *fe_timing* )) ; for dianaio (eval-when (compile load eval)(ct_load 'release)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Call-able Functions/Macros -- ;;; The interface to the rest of the Ada Tutor (or the outside world) ;;; expects six streams. The first is a source stream for Ada input. ;;; The second is a stream for interpreter output (such as a line ;;; printer, for a listing). The third is a stream for user responses ;;; to questions given in the fourth stream, error output. The fifth ;;; is a stream for user input to his/her Ada program. The last ;;; is a stream for user output from his/her Ada program. Very ;;; often, the first stream will be an open file and the rest will ;;; be the terminal. However, pop-up windows could be supplied for ;;; for error messages, user program IO, etc. On unix, these should ;;; be the analogous ports. The first arg is required; the rest are ;;; optional and default to the terminal. AdaF is a version which ;;; expects a filename (path) instead of a stream as its first arg. ;;; Why not make this use &optional instead of a macro? ++mlm ;;; This can now be called with a list as the first form, ;;; not just a string, to allow separate compilations ;;; It only intializes once prior to building the diana trees. ;;;; (defun adaf macro (form) ;;;; " Executes the C*T Ada Interpreter with input from a file. Required first arg is string containing pathname for the file, or a list of strings containing a pathname, for separate comp. There are five optional stream args: listing output, error in, error out, user program input, and user program output. " (selfinsertmacro form `(progn (incremental_build_diana_init ) (adaf_int ',(cond ((listp (second form)) (second form)) (t (list (second form)))) ;Ada Source Pathstring ;or list of Pathstrings ,(or (third form) '(terminal_output)) ;Listing Output Stream ,(or (fourth form) '(terminal_input)) ;Error Input Stream ,(or (fifth form) '(terminal_output)) ;Error Output Stream ,(or (sixth form) '(terminal_input)) ;User Input Stream ,(or (seventh form) '(terminal_output));User Output Stream nil)))) ;;; This version supports using ct_load style symbolic names. ;;; It should now support having a list of symbolic names, ;;; to allow separate compilations. If the load_symbol is a ;;; list then it mapcars ct_load_get over it to return the ;;; list of Pathstrings, otherwise it passes the result of ;;; listing ct_load_get on load_symbol. ;;;; (defun adag (load_symbol &optional ;;;; (list_stream (terminal_output)) (error_in (terminal_input)) (error_out (terminal_output)) (user_in (terminal_input)) (user_out (terminal_output))) (incremental_build_diana_init ) (cond ((listp load_symbol) (adaf_int (mapcar #'ct_load_get load_symbol) list_stream error_in error_out user_in user_out nil)) (t (adaf_int (list (ct_load_get load_symbol)) list_stream error_in error_out user_in user_out nil)))) ;;;; (defun adai (inlib env files &optional ;;;; (list_stream (terminal_output)) (error_in (terminal_input)) (error_out (terminal_output)) (user_in (terminal_input)) (user_out (terminal_output))) (incremental_build_diana_init ) (cond ((and (null inlib) (null env)) (adaf_int files list_stream error_in error_out user_in user_out "true" )) ((null env) (adaf_int (append (cond ((consp inlib) inlib) (t (list inlib))) files ) list_stream error_in error_out user_in user_out "truein")) ((null inlib) (adaf_int (append (cond ((consp env) env) (t (list env))) files ) list_stream error_in error_out user_in user_out "trueenv")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externals, continued ;;;;;;;;; (defun run_diana macro (form) ;;;;;;;;; " There are five optional stream args: listing output, error in, error out, user program input, and user program output. " (selfinsertmacro form `(run_diana_int ,(second form) ;Ada Source Stream ,(or (third form) '(terminal_output)) ;Listing Output Stream ,(or (fourth form) '(terminal_input)) ;Error Input Stream ,(or (fifth form) '(terminal_output)) ;Error Output Stream ,(or (sixth form) '(terminal_input)) ;User Input Stream ,(or (seventh form) '(terminal_output)) ;User Output Stream ))) ;;; (defun ada macro (form) ;;; " Executes the C*T Ada Interpreter with input from a stream/port. Required first arg is input stream to read from (eg, an open file). There are five optional stream args: listing output, error in, error out, user program input, and user program output. " (selfinsertmacro form `(ada_int ,(second form) ;Ada Source Stream ,(or (third form) '(terminal_output)) ;Listing Output Stream ,(or (fourth form) '(terminal_input)) ;Error Input Stream ,(or (fifth form) '(terminal_output)) ;Error Output Stream ,(or (sixth form) '(terminal_input)) ;User Input Stream ,(or (seventh form) '(terminal_output)) ;User Output Stream ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Macros ;;; ;;; Normally the following function should only be called from ;;; within the C*T Ada Interpreter top level proper, which is ;;; the function Ada_Int (or the macros Ada, AdaF, or AdaG). ;;; NB: This replaces older versions in files called adafe, toplev!! ;;;;; (defun adafe (srcin listout errin errout userin userout) ;;;;; (let ((*diana_tree* (incremental_build_diana ;Do the REAL work. srcin listout ; source => listing errin errout ; errors and correction userin userout))) ; standard interaction (cond ((or (greaterp *parse_errors* 0) ;Cleanup after FE. (greaterp *semantic_errors* 0)) (skipline listout))) (fe_result (and *diana_tree* ;Run-p Flag. (lessp *parse_errors* 1.) (lessp *semantic_errors* 1.)) *parse_errors* *semantic_errors* *diana_tree*))) ;;;;;;; (defun ada_int (srcin listout errin errout userin userout) ;;;;;;; " The C*T Ada Interpreter Top Level. " (time_line listout) (ada_version_msg listout) (*catch 'lossage (let* ((base 10.) (ibase 10.) (*nopoint t) (*lossage* t) (t1 #+lispm (multiple-value-bind (a b c d e f g)(time:get-time)(list a b c)) #+franz (status localtime)) ;;Start FE timing. (fe_res (adafe srcin listout ;;Run the Front End. errin errout userin userout)) (t2 #+lispm (multiple-value-bind (a b c d e f g)(time:get-time)(list a b c)) #+franz (status localtime)) ;;Stop FE timing. (runflg (fe_result%runflg fe_res)) ;;Extract FE results. (synerrs (fe_result%synerrs fe_res)) (semerrs (fe_result%semerrs fe_res)) (diana (fe_result%diana fe_res)) (fe_timing (elapsed_time t2 t1)) (be_result nil)) (freshline listout) (cond ((or runflg (> synerrs 0) (> semerrs 0)) (ct_format listout "A total of ~a syntax error~a and ~a static semantic error~a were detected.~%" synerrs (s-if-plural synerrs) semerrs (s-if-plural semerrs)))) (setq *fe_timing* fe_timing) (cond ((status feature qawimps) (print_elapsed listout "Time Elapsed = " fe_timing))) (cond (runflg (setq be_result ;NB: BE timing returned by effect. (run_diana_int diana listout errin errout userin userout)) (cond ((status feature qawimps) (print_elapsed userout "Total Time Elapsed = " (plus fe_timing *be_timing*))))) ((greaterp synerrs 0) (skipline userout) (setq *incremental_diana* nil) (ct_format userout "Your program will not execute due to syntax errors. ~%")) ((greaterp semerrs 0) (skipline userout) (setq *incremental_diana* nil) (ct_format userout "Your program will not execute due to static semantic errors. ~%")) (t (ct_format userout (format nil "~%Your input was probably not an Ada program.~%~ Program execution has ended.~%")))) (time_line userout) be_result))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internals continued ;;;;;;;;;;;;; (defun careful_adabe (diana listout errin errout userin userout) ;;;;;;;;;;;;; (cond ((not (status feature debugging)) (let ((ans (errset (adabe diana listout errin errout userin userout) nil))) ;Suppress error msg output (cond (ans (car ans)) (t (skipline listout) (ct_format listout (format nil "Your program's execution has been terminated.~%~ Your program probably uses Ada constructs or features that ~%~ are not now fully supported.~%")) nil) ))) (t (adabe diana listout errin errout userin userout)))) ;;; Mark has modified this (26-apr-83) to allow re-entrant timing. ;;; assumes if called with diana nil, must be a resume. ;;;;;;;;;;;; (defun elapsed_time(t1 t2) ;;;;;;;;;;;; (let* ((hrs (- (third t1)(third t2))) (mins (- (second t1)(second t2))) (secs (- (first t1)(first t2)))) (cond ((lessp secs 0) (%= secs (+ secs 60)) (%= mins (1- mins))) ((lessp mins 0) (%= mins (+ mins 60)) (%= hrs (1- hrs))) ((lessp hrs 0) (%= hrs (+ hrs 24)) )) (plus (times 3600 hrs) (times 60 mins) secs))) ;;;;;;;;;;;;; (defun run_diana_int (diana listout errin errout userin userout) ;;;;;;;;;;;;; (let ((*userin* userin)) (ada_io_init)) (cond ((null diana) (ct_format userout (format nil "~%The interpreter is unable to begin executing your program.~% ~ A complete representation of your program could not be constructed.~%"))) (t (let ((t3 0) (t4 0) (be_result nil)) (skipline userout) (ct_format userout "~%Computer * Thought Ada (tm): ~A : ~a~%~a~%" *release* (time:print-current-time nil) (protect 'interpreter)) ; protection on the frontend (cond (diana (ct_princ "Program execution is beginning." userout) (setq *be_timing* 0)) (t (ct_princ "Resume Ada Execution" userout)));Restart after wrench. (skipline userout) (setq diana (diana_threadify diana)) #+lispm (multiple-value-bind (a b c d e f g) (time:get-time)(setq t3 (list a b c d e f g))) #+franz (setq t3 (status localtime)) ;Start BE timing. (*catch 'lossage (cond ((not (status feature be_loss)) (let ((zzz (errset ;Run the Back End. (careful_adabe diana userout errin errout userin userout) nil))) (cond ((null zzz) (setq be_result '|fail|) (apologize_be listout userout)) (t (setq be_result (car zzz)))))) (t (setq be_result ;Run the Back End. (careful_adabe diana userout errin errout userin userout))))) #+lispm (multiple-value-bind (a b c d e f g) (time:get-time)(setq t4 (list a b c d e f g))) #+franz (setq t4 (status localtime)) ;Stop BE timing. (flush_out_file) (skipline userout) (cond (be_result (ct_format userout (format nil "~%Your program's execution has been terminated.~%~ The error messages above describe the cause of this termination.")))) (ct_format userout "~%Program execution has ended.~%") ;;; The PLUS in the next expression allows remembering how much ;;; time was lapsing across wrenches. (cond ((> *diana_node_counter* 0) (cond ((status feature qawimps) (ct_format userout "Diana Nodes = ~D.~%" *diana_node_counter*))))) (cond ((status feature qawimps) (ct_format userout "Diana Virtual Machine Cycles = ~D.~%" *dvm_cycle_counter*))) (setq *be_timing* (plus *be_timing* (elapsed_time t4 t3))) (cond ((eq *be_timing* 0) (setq *be_timing* 1))) (cond ((status feature qawimps) (print_elapsed userout "Elapsed time = " *be_timing*) (ct_format userout "~%Diana Cycles Per Second = ~D.~%Total number of lines in source = ~D.~%" (quotient (float *dvm_cycle_counter*) (float *be_timing*)) (1- la_srcpos)))) (time_line userout) (delete_textio_temp_file) (delete_seqio_temp_file) (delete_dirio_temp_file) be_result)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internals, continued ;;; These are used to save and restore diana trees that are saved ;;; used only in adaf_int ;;;;;;;;; (defun save_tree (pathname) ;;;;;;;;; (let ((prinlevel nil) (prinlength nil)) (diana_ct_id (ct_send *di_out* 'diana)) ;to ensure everything has a ct_id (write_diana_to_file (ct_send *di_out* 'diana) pathname) )) ;;;;;;;;;;;; (defun restore_tree (di_pathname) ;;;;;;;;;;;; (let ((di (make_library_unit (gensym) nil))) (ct_send di 'internal_representation (list di (ct_send di 'library_unit_name) di_pathname)))) ;;;;;;;;;;; (defun ext_of_file (pathname) ;;;;;;;;;;; (loop with ext = nil with file = (bare_file_name pathname) for char in (reverse (list_of_chars file)) until (memq char '(#/_)) do (ct_push char ext) finally (return #+lispm (apply 'string-append ext) #+franz (get_pname (apply 'string-append ext) )))) ;;;;;;;; (defun adaf_int (pathlist listout errin errout userin userout idebug) ;;;;;;;; (setq *userout* userout) (setq *listout* listout) (setq *lossage* t) (setq *lose_stream* nil) (let* ((*continue_inc_diana* t) (*not_wffp_diana* t) (firstfile "true") (result (*catch 'lex_eof (*catch 'cant_continue (*catch 'too_many_errors (*catch '*not_wffp_diana* (mapcar #'(lambda (path ) " Expr version of AdaF with fixed number of req'd, eval'ed args. " (let* ((file path ) (f (ct_probef file))) (setq *path* path) (cond ;; First, check to see if we are recovering from being ;; wrenched, by asking the Tutor's function. ;; If so, don't ;; bother opening any files; call adabe with dummy ;; arguments. ((and (status_feature 'tutor) (ada_wrenched_p_fcn)) ;;Was: (send userin ':wrenched_p) (run_diana_int nil listout errin errout userin userout)) ;; If not recovering from wrench, check normal things. (f (with_open_infile (srcin f) (let ((ext (ext_of_file path))) (cond (firstfile ;this is the first file (setq firstfile nil) (cond ((equal idebug "true") ;; no inlib or env (cond ((status feature fe_loss) (ada_int_inc srcin listout errin errout userin userout)) (t (let ((zzz (errset (ada_int_inc srcin listout errin errout userin userout) nil))) (cond ((null zzz) (apologize_fe listout errout) (car zzz)) (t (car zzz))))))) ((equal idebug "truein") ;;there is an inlib (%= *incremental_diana* (restore_tree path)) *incremental_diana*) ((equal idebug "trueenv");; there is an environment (cond ((equal ext "ada") (cond ((status feature fe_loss) (ada_int_inc srcin *bit_bucket* *bit_bucket* *bit_bucket* *bit_bucket* *bit_bucket*)) (t (let ((zzz (errset (ada_int_inc srcin *bit_bucket* *bit_bucket* *bit_bucket* *bit_bucket* *bit_bucket*) nil))) (cond ((null zzz) (apologize_fe listout errout) (car zzz)) (t (car zzz)))) ))) ((equal ext "int") (%= *incremental_diana* (restore_tree path)) *incremental_diana*) )) (t (cond ((status feature fe_loss) (ada_int_inc srcin listout errin errout userin userout)) (t (let ((zzz (errset (ada_int_inc srcin listout errin errout userin userout) nil))) (cond ((null zzz) (apologize_fe listout errout) (car zzz)) (t (car zzz)))))))));; end of firstfile (t (cond ((status feature fe_loss) (ada_int_inc srcin listout errin errout userin userout)) (t (let ((zzz (errset (ada_int_inc srcin listout errin errout userin userout) nil))) (cond ((null zzz) (apologize_fe listout errout) (car zzz)) (t (car zzz))))))))) ;end of let ));;end of with open-file (t ;; there is no file with that pathname (ct_format listout "~%Error -- Your input file for Ada source code:~%") (ct_format errout "~A~%does not exist.~%Program execution has ended.~2%" file) (setq *not_wffp_diana* nil) (*throw '*not_wffp_diana* *not_wffp_diana*) nil))));; end of the lambda expression pathlist))))))) (cond ( *awaiting_incomplete_type* (let ((incomptt *awaiting_incomplete_type*)) (setq *awaiting_incomplete_type* nil) (mapc #'(lambda(type) (let ((asid (diana_get type 'as_id))) (cond ((diana_get asid 'sm_type_spec)) (t (ct_format listout "~%There is no full declaration for the incomplete type ~A~%" (implode (uplowlist (cadr (diana_get asid 'lx_symrep))))) (ct_format listout "Description: LRM Section 3.8.1, Paragraph 3~%") (ct_format listout "Example: LRM Section 3.8.1, Paragraph 6-7~%") (ct_format userout "~%There is no full declaration for the incomplete type ~A~%" (implode (uplowlist (cadr (diana_get asid 'lx_symrep))))) (ct_format userout "Description: LRM Section 7.4, Paragraph 4~%") (ct_format userout "Example: LRM Section 3.8.1, Paragraph 6-7~%") (setq result (list nil)))))) incomptt)))) (cond ((eq result 'cant_continue) (ct_format listout (format nil "~%Your program's analysis has been terminated.~%~ The interpreter is unable to continue its analysis.~%")) (ct_format errout (format nil "~%Your program's analysis has been terminated.~%~ The interpreter is unable to continue its analysis.~%")) (setq fred (list nil listout errin errout userin userout))) ((eq result 'too_many_errors) (ct_format listout (format nil "~%Your program's analysis has been terminated.~%~ Too many errors have occurred for the analysis to continue.~%")) (ct_format errout (format nil "~%Your program's analysis has been terminated.~%~ Too many errors have occurred for the analysis to continue.~%")) (setq fred (list nil listout errin errout userin userout))) ((eq result 'lex_eof) (ct_format listout "~%Unexpected end of file encountere~%") (ct_format errout "~%Unexpected end of file encountered~%") (setq fred (list nil listout errin errout userin userout))) ((and result *continue_inc_diana* (null idebug)) (run_diana_int (car (last result)) listout errin errout userin userout)) (idebug (setq fred (list (car (last result)) listout errin errout userin userout)) (setq *di_out* (make_library_unit (gensym) (car fred))) fred)) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Next three functions should be moved to TIME.L -- mlm ++ ;;;;;;;;; (defun time_line (stream) ;;;;;;;;; (ct_format stream "~%-- -- -- -- -- -- -- -- -- -- -- -- -- ~%") ;(nice_current_time stream) ;(ct_format stream "~%") nil) ;;;;;;;;;;;;;;;;; (defun time_diff_in_secs (t2 t1) ;;;;;;;;;;;;;;;;; ;;; Inputs are times in milliseconds. (quotient (float (difference t2 t1)) 1000.0)) ;;;;;;;;;;;;; (defun print_elapsed (stream msg tim) ;;;;;;;;;;;;; (ct_format stream "~A~4F seconds.~%" msg tim)) ;;;;;;;;;;;;;;; (defun ada_version_msg (stream) ;;;;;;;;;;;;;;; (ct_format stream "~%Computer * Thought Ada (tm): ~A : ~A~%~a" *release* (time:print-current-time nil) (protect 'interpreter)) ; protection on the frontend nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Stuff for Dumping out CTADA on Unix. ;;;;;;;;;;;; (defun apologize_be (listout userout) ;;;;;;;;;;;; ;(beep) (ct_format listout (format nil "~%The interpreter is unable to finish executing your program.~%~ This situation is often the result of invalid Ada programs. Please ~%~ report this behavior to the C*T Customer Support Department.~%")) (ct_format userout (format nil "~%The interpreter is unable to finish executing your program.~%~ This situation is often the result of invalid Ada programs. Please ~%~ report this behavior to the C*T Customer Support Department.~%")) ) ;;;;;;;;;;;; (defun apologize_fe (listout errout) ;;;;;;;;;;;; ;(beep) (ct_format listout (format nil "~%The interpreter is unable to finish analyzing your program.~%~ This situation is often the result of invalid Ada programs. Please ~%~ report this behavior to the C*T Customer Support Department.~%")) (ct_format errout (format nil "~%The interpreter is unable to finish analyzing your program.~%~ This situation is often the result of invalid Ada programs. Please ~%~ report this behavior to the C*T Customer Support Department.~%")) ) ;;;;;;;;;;;;;;;;;; (defun careful_ada_toplev () ;;;;;;;;;;;;;;;;;; (prog (xxx yyy zzz) lp (setq zzz (errset (progn (ct_terpri) (ct_princ "> ") (setq xxx (ct_read)) (setq yyy (eval xxx)) (ct_print yyy)) (status feature debugging))) (cond ((null zzz) (apologize))) (go lp))) ;;;;;;;;;;;;;;; (defun ct_ask_stringpm (message &optional (stream terminal-io)) ;;;;;;;;;;;;;;; (format stream "~&~a" message) (readline)) #+lispm ;;;;;;; (defun dumpada ;;;;;;; (&optional (subdir "" subdirp) (timing nil timep) (report nil reportp) (pkghost "" hostp)) ;;; it will now force the going through the front end (sstatus nofeature fe_initialized) ;;These tests are a little simple minded. Should really check ;;to see if the "thing" looks ok ;;This only makes sense if this build will be at C*T (unless subdirp (setq subdir (ct_ask_stringpm "Ct_load subdirectory? "))) (unless timep (setq timing (y-or-n-p "Show execution timing information? "))) (unless reportp (setq report (y-or-n-p "Load the report package? "))) (unless hostp (setq pkghost (ct_ask_stringpm "Directory containing the standard environment files? "))) (sstatus nofeature debugging) ; new way (cond (timing (sstatus feature qawimps)) (t (sstatus nofeature qawimps))) ;;;; set up the ct_load_defs for stdpg,syspkg,textiop ctbasio ;;;; seqiop diriop ioexpkg calendp repbody repspec (ct_load_put 'stdpkg (string-append pkghost "stdpkg.ada")) (ct_load_subdir_def stdpkg "no_subdir") (ct_load_put 'syspkg (string-append pkghost "syspkg.ada")) (ct_load_subdir_def syspkg "no_subdir") (ct_load_put 'ioexpkg (string-append pkghost "ioexpkg.ada")) (ct_load_subdir_def ioexpkg "no_subdir") (ct_load_put 'textiop (string-append pkghost "textiop.ada")) (ct_load_subdir_def textiop "no_subdir") (ct_load_put 'seqiop (string-append pkghost "seqiop.ada")) (ct_load_subdir_def seqiop "no_subdir") (ct_load_put 'diriop (string-append pkghost "diriop.ada")) (ct_load_subdir_def diriop "no_subdir") (ct_load_put 'calendp (string-append pkghost "calendp.ada")) (ct_load_subdir_def calendp "no_subdir") (ct_load_put 'repbody (string-append pkghost "repbody.ada")) (ct_load_subdir_def repbody "no_subdir") (ct_load_put 'repspec (string-append pkghost "repspec.ada")) (ct_load_subdir_def repspec "no_subdir") (ct_load_put 'chkfile (string-append pkghost "chkfile.ada")) (ct_load_subdir_def chkfile "no_subdir") (ct_load_put 'ctbasio (string-append pkghost "ctbasio.ada")) (ct_load_subdir_def ctbasio "no_subdir") (ct_load_put 'initial (string-append pkghost "initial.ada")) (ct_load_subdir_def initial "no_subdir") (setq *ct_load_subdir* subdir) (cond (report (sstatus feature report);stdenv will check and go through ;the front_end with repspec repbody and checkfile (adag 'initial)) (t (sstatus nofeature report) (adag 'initial))) 'OK) ;;;;;;; (defun dumpada_noexit (strin) ;;;;;;; (setq *release* strin) ; Anything you like will do. #+franz (progn (ct_format (standard_output) "use this release string-~A ? (y/n)" *release*) (setq response (ct_read)) (cond ((not (memq response '(y yes))) (ct_format (standard_output) "please provide the release string ") (setq *release* (ct_read)))) (setq user-top-level (function ada_toplev)) (chdir "!/ct!/interp") (ct_format (standard_output) "~2&Use !'!/ct!/interp!/installada!' to install.~%")) (sstatus feature demo) ; obsolete (sstatus nofeature debugging) ; new way (*rset nil) ; run faster #+franz (progn (sstatus translink on) ; and faster! (gc) (ct_format (standard_output) "do you wish to set the *ct_load_ subdir* to latest? (y/n) ") (setq response (ct_read)) (cond ((memq response '(y yes)) (setq *ct_load_subdir* "latest")) (t (setq *ct_load_subdir* ""))) (ct_format (standard_output) "do you wish to make a kneecapped version( no seqio or dirio)? (y/n) ") (setq response (ct_read)) (cond ((memq response '(y yes)) (sstatus feature *kneecapped*)) (t (sstatus nofeature *kneecapped*))) (ct_format (standard_output) "do you wish to load the report package? (y/n) ") (setq response (ct_read)) (cond ((memq response '(y yes)) (adaf ("/mnt/penny/repspec.ada" "/mnt/penny/repbody.ada" "/ct/interp/initial.ada")) (internalize_package 'report) ) (t (adaf "/ct/interp/initial.ada"))) (setq *ct_load_subdir* "") (dumplisp) (beep) ) 'OK) #+franz ;;;;;;; (defun dumpada (strin) ;;;;;;; (setq *release* strin) ; Anything you like will do. #+franz (progn (ct_format (standard_output) "use this release string-~A ? (y/n)" *release*) (setq response (ct_read)) (cond ((not (memq response '(y yes))) (ct_format (standard_output) "please provide the release string ") (setq *release* (ct_read)))) (setq user-top-level (function ada_toplev)) (chdir "!/ct!/interp") (ct_format (standard_output) "~2&Use !'!/ct!/interp!/installada!' to install.~%")) (sstatus feature demo) ; obsolete (sstatus nofeature debugging) ; new way (*rset nil) ; run faster #+franz (progn (sstatus translink on) ; and faster! (gc) (ct_format (standard_output) "do you wish to set the *ct_load_ subdir* to latest? (y/n) ") (setq response (ct_read)) (cond ((memq response '(y yes)) (setq *ct_load_subdir* "latest")) (t (setq *ct_load_subdir* ""))) (ct_format (standard_output) "do you wish to make a kneecapped version( no seqio or dirio)? (y/n) ") (setq response (ct_read)) (cond ((memq response '(y yes)) (sstatus feature *kneecapped*)) (t (sstatus nofeature *kneecapped*))) (ct_format (standard_output) "do you wish to load the report package? (y/n) ") (setq response (ct_read)) (cond ((memq response '(y yes)) (adaf ("/mnt/penny/repspec.ada" "/mnt/penny/repbody.ada" "/ct/interp/initial.ada")) (internalize_package 'report) ) (t (adaf "/ct/interp/initial.ada"))) (setq *ct_load_subdir* "") (dumplisp) (beep) (exit )) 'OK) #+Lispm ;;;;;;;;;; (defun ada_toplev () ;;;;;;;;;; (lose 'wrong_op_sys 'ada_toplev '("The Ada Top Level is only for Unix."))) #+franz ;;;;;;;;;;; (defun ada_toplev () ;;;;;;;;;;; (prog (jclargs?) (cond ((eq (getenv 'ctadaflg) 'wizard) (debug_ctada))) (setq jclargs? (> (argv -1) 1)) (cond (jclargs? (let ((z (errset (eval `(adaf ,(argv 1))) (status feature debugging)))) (cond ((null z) (apologize))) (exit *error_status*))) (t (time_line (standard_output)) (ada_version_msg (standard_output)) (cond ((status feature debugging) (ct_format (standard_output) "-- (adaf !"!") will run from a filename string. ~% -- (adaf (!"!" !"!" ... ) will run from a list of filename strings.~% -- (adag !') will run from a ct_load file id. ~% -- (adag (! ...)) will run from a list ct_load file ids. ~% -- (exit) will return to unix. ~%"))) (setq user-top-level (function careful_ada_toplev)))))) ;;;;;;;;;;; (defun debug_ctada () ;;;;;;;;;;; (sstatus nofeature demo) ; obsolete (sstatus feature debugging) ; new way #+franz (setq user-top-level 'userexec); the usual default #+franz (sstatus translink nil) ;Unsnap the links (*rset t) ;Ok (=default) on LM, too. (ct_format (terminal_output) "~&Type !'!(reset!)!' to return to top level LISP.~%") 'OK) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Edit History: ;;; ;;; ;;; ;;; Created by Paul Robertson and Mark Miller 8-Feb-83 ;;; ;;; ;;; ;;; Edit by MLM (to fix Time) 25-Apr-83 ;;; ;;; Edit by John (to support interrupt/restart) 25-Apr-83 ;;; ;;; Edit by MLM (to Errset-Protect Backend Demos) 26-Apr-83 ;;; ;;; Edit by MLM (use format pkg, fix version nums) 6-May-83 ;;; ;;; Edit by MLM (complete May 6 edits, flush fe_result) 9-May-83 ;;; ;;; Edit by GeneC (interrupt/restart: change functions) 14-May-83 ;;; ;;; Edit by MLM (to merge in obsolete adafe file) 15-May-83 ;;; ;;; Edit by MLM (to ct_includef intrp_dcl, not fe_decl). 16-May-83 ;;; ;;; Edit by MLM to change intrp_dcl to intrpdcl and to ;;; ;;; merge in dumpada.l 18-May-83 ;;; ;;; Edit by MLM to change BREAK/FERROR/etc to LOSE, and 26-May-83 ;;; ;;; to fix listing output, etc. ;;; ;;; Edit by MLM to fix bugs in version 26. => v. 27. 27-May-83 ;;; ;;; ;;; ;;; eof ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;