;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- ;;; $Header: /ct/interp/stdenv.l,v 1.96 85/06/25 11:12:42 bill Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; stdenv ;;; ;;; Paul Robertson January 30, 1983 ;;; ;;; ;;; ;;; The Ada Predefined standard environment ;;; ;;; ;;; ;;; This file is part of a proprietary software project. Source ;;; ;;; code and documentation describing implementation details are ;;; ;;; available on a confidential, non-disclosure basis only. These ;;; ;;; materials, including this file in particular, are trade secrets ;;; ;;; of Computer * Thought Corporation. ;;; ;;; ;;; ;;; (c) Copyright 1982 and 1983, Computer * Thought Corporation. ;;; ;;; All Rights Reserved. ;;; ;;; ;;; ;;; Reference materials: ;;; ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; ;;; Charniak et al., 198?. Artificial Intelligence Programming. ;;; ;;; ;;; ;;; The following code assumes familiarity with the above. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ensure presence of needed files. (eval-when (compile load eval) (ct_load 'aip)) ;AIP macros pkg. (eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg. (eval-when (compile load eval) (ct_load 'time)) ;Timing functions. (eval-when (compile load eval) (ct_load 'diana)) ; diana toolkit. (eval-when (compile load eval) (ct_load 'sema)) ; to get sc_diana. (eval-when (compile load eval) (ct_load 'operators)) ; to get op funs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #+franz (declare (macros t)) (declare (ct_includef 'intrpdcl)) ; get the specials (eval-when (compile load eval) (ct_load 'ferec)) ; get the macros etc. (eval-when (compile load) (setq *debugparser* nil)) ;;; declare the fexpr functions -AM- (declare (*fexpr is_standard_procedure is_standard_function)) ;;; these macros will be replaced by mapping add_name over a list. (eval-when (compile load eval) (def_record_type ada_param nil (mode name type default)) (declare (special idrep lispname params returntype));temporary hack++ ;;;;;;;;;;;;;;;;;;; (defun internalize_package (name) ;;;;;;;;;;;;;;;;;;; (let ((named_packages (ada_declared `(lex_ident ,(uplowlist (exploden name))) nil 'library_unit t))) (ct_selectq (length named_packages) (1 (setq **standard_env** (diana_get (first named_packages) 'ct_named_context)) (setq **current_block** **standard_env**)) (0 (ct_format (terminal_output) "Error: no such package~&")) (otherwise (ct_format (terminal_output) "Error: ambiguous package specified~&") (setq **standard_env** (diana_get (first named_packages) 'ct_named_context)))))) ;;;;;;;;;;;;;;;;;;;;; (defun internalize_procedure (name) ;;;;;;;;;;;;;;;;;;;;; (let ((named_procedure (ada_declared `(lex_ident ,(uplowlist (exploden name))) nil 'library_unit t))) (ct_selectq (length named_procedure) (1 (setq **standard_env** (diana_get (first named_procedure) 'ct_named_context)) (setq **current_block** **standard_env**)) (0 (ct_format (terminal_output) "Error: no such procedure~&")) (otherwise (ct_format (terminal_output) "Error: ambiguous procedure specified~&") (setq **standard_env** (diana_get (first named_procedure) 'ct_named_context)))))) ;;;;;;;;;;;;;;; (defun include_package (spec body init) ;;;;;;;;;;;;;;; (incremental_build_diana_init) (cond (spec (with_open_infile (pkg spec) (ada_int_inc pkg (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output))))) (cond (body (with_open_infile (pkg body) (ada_int_inc pkg (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output))))) (setq **standard_env** **current_block**) (cond (init (adaf_int (list init) (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output) nil)))) ;;;;;;;;;;;; (defun with_package macro (l) ;;;;;;;;;;;; `(let* ((named_package (ada_declared '(lex_ident ,(uplowlist (exploden (second l)))) nil '(library_unit package generic_unit) t)) (**library_unit** (diana_get (first named_package) 'ct_named_context)) (**current_block** **library_unit**) ) ,@(cddr l))) ;;;;;;;;;;;;;;;;;;;;; (defun is_standard_procedure fexpr (l) ;;;;;;;;;;;;;;;;;;;;; (let* ((adaname (first l)) ; name of the Ada procedure. (lispname (implode (exploden (second l)))) ; name of lisp function to call. (params (third l)) ; list of parameter triples (idrep `(lex_ident ,(uplowlist (exploden (first l))))) (*bnl* 0) (*pnl* 0) (others (ada_declared idrep nil 'procedure t)) (nubody (sc_diana dn_predefined_procedure ct_lisp_func lispname)) (nuspec (sc_diana dn_procedure as_param_s (build_parameters params) ))) ;;now we need to find the matching stub, and fix in the body. (setq others (mapcan #'(lambda (fun) (cond ((eq (diana_nodetype_get (diana_get fun 'sm_body)) 'dn_stub) (list fun)))) others)) ; (break look-at-others-std-fun) (setq others (with_same_type_profile (sc_diana dn_proc_id ; this is a function id. lx_symrep idrep sm_body nubody sm_spec nuspec) others)) (cond ((> (length others) 1)(break cant-resolve-bif-in-std-fun)) ((< (length others) 1)(break no-matching-bif-spec-in-std-fun))) ; (break look-at-others) (diana_put (first others) nubody 'sm_body) ; (diana_put (first others) *pnl* 'ct_pnl) )) ;;;;;;;;;;;;;;;;;;;; (defun is_standard_function fexpr (l) ;;;;;;;;;;;;;;;;;;;; (let*((adaname (first l)) ; name of the Ada function. (lispname (implode (exploden (second l)))) ; name of lisp function to call. (params (third l)) ; list of parameter triples (returntype (ada_declared `(lex_ident ,(uplowlist (exploden (fourth l)))) nil 'type)) ; the typemark for returned type. (idrep `(lex_ident ,(uplowlist (exploden (first l))))) (*bnl* 0) (*pnl* 0) (others (ada_declared idrep nil 'function t)) (nubody (sc_diana dn_predefined_function ct_lisp_func lispname)) (nuspec (sc_diana dn_function as_param_s (build_parameters params) as_name_void returntype ))) ;;now we need to find the matching stub, and fix in the body. (setq others (mapcan #'(lambda (fun) (cond ((eq (diana_nodetype_get (diana_get fun 'sm_body)) 'dn_stub) (list fun)))) others)) ; (break look-at-others-std-fun) (setq others (with_same_type_profile (sc_diana dn_function_id ; this is a function id. lx_symrep idrep sm_body nubody sm_spec nuspec) others)) (cond ((> (length others) 1)(break cant-resolve-bif-in-std-fun)) ((< (length others) 1)(break no-matching-bif-spec-in-std-fun))) ; (break look-at-others) (diana_put (first others) nubody 'sm_body) ; (diana_put (first others) *pnl* 'ct_pnl) )) ;; the old is_builtin_operator ;;;;;;;;;;;;;;;;;;;;;;; (defun old_is_builtin_operator fexpr (l) ;;;;;;;;;;;;;;;;;;;;;;; (let ((adaname (first l)) ; name of the Ada function. (lispname (implode (exploden (second l)))) ; name of lisp function to call. (params (third l)) ; list of parameter triples (returntype (ada_declared `(lex_ident ,(uplowlist (exploden (fourth l)))) nil 'type)) ; the typemark for returned type. (idrep `(lex_ident ,(uplowlist (exploden (first l))))) (sdrep `(lex_string ,(uplowlist (exploden (first l))))) (*bnl* 0) (*pnl* 0)) (add_name idrep 'function (sc_diana dn_function_id ; this is a procedure id. lx_symrep sdrep sm_body (sc_diana dn_predefined_function ct_lisp_func lispname) sm_spec (sc_diana dn_function as_param_s (build_parameters params) as_name_void returntype )) nil))) ;;;;;;;;;;;;;;;;;;;;;;; (defun old_is_new_builtin_operator fexpr (l) ;;;;;;;;;;;;;;;;;;;;;;; (let ((adaname (first l)) ; name of the Ada function. (lispname (implode (exploden (second l)))) ; name of lisp function to call. (params (third l)) ; list of parameter triples (returntype (ada_declared `(lex_ident ,(uplowlist (exploden (fourth l)))) nil 'type)) ; the typemark for returned type. (idrep `(lex_ident ,(uplowlist (exploden (first l))))) (sdrep `(lex_string ,(uplowlist (exploden (first l))))) (*bnl* 0) (*pnl* 0)) (add_name idrep 'function (sc_diana dn_function_id ; this is a procedure id. lx_symrep sdrep sm_body (sc_diana dn_predefined_simple_function ct_lisp_func lispname) sm_spec (sc_diana dn_function as_param_s (build_parameters params) as_name_void returntype )) nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun old_is_new_builtin_operator_internal (&rest l) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let ((adaname (first l)) ; name of the Ada function. (lispname (implode (exploden (second l)))) ; name of lisp function to call. (params (third l)) ; list of parameter triples (returntype (ada_declared `(lex_ident ,(uplowlist (exploden (fourth l)))) nil 'type)) (idrep `(lex_ident ,(uplowlist (exploden (first l))))) (sdrep `(lex_string ,(uplowlist (exploden (first l))))) (*bnl* 0) (*pnl* 0)) (add_name idrep 'function (sc_diana dn_function_id ; this is a procedure id. lx_symrep sdrep sm_body (sc_diana dn_predefined_simple_function ct_lisp_func lispname) sm_spec (sc_diana dn_function as_param_s (build_parameters_internal params) as_name_void returntype )) nil))) ;;;;;;;;;;;;;;;;;;; (defun is_new_builtin_operator fexpr (l) ;;;;;;;;;;;;;;;;;;; (let* ((adaname (first l)) ; name of the Ada function. (lispname (implode (exploden (second l)))) ; name of lisp function to call. (params (third l)) ; list of parameter triples (returntype (ada_declared `(lex_ident ,(uplowlist (exploden (fourth l)))) nil 'type)) ; the typemark for returned type. (idrep `(lex_ident ,(uplowlist (exploden (first l))))) (sdrep `(lex_string ,(uplowlist (exploden (first l))))) (*bnl* 0) (*pnl* 0) (others (ada_declared idrep nil 'function t)) (nubody (sc_diana dn_predefined_simple_function ct_lisp_func lispname)) (nuspec (sc_diana dn_function as_param_s (build_parameters params) as_name_void returntype ))) ;;now we need to find the matching stub, and fix in the body. (setq others (mapcan #'(lambda (fun) (cond ((eq (diana_nodetype_get (diana_get fun 'sm_body)) 'dn_stub) (list fun)))) others)) ; (break look-at-others) (setq others (with_same_type_profile (sc_diana dn_function_id ; this is a function id. lx_symrep idrep sm_body nubody sm_spec nuspec) others)) (cond ((> (length others) 1)(break cant-resolve-bif)) ((< (length others) 1)(break no-matching-bif-spec))) ; (break look-at-others) (diana_put (first others) nubody 'sm_body) ; (diana_put (first others) *pnl* 'ct_pnl) )) ;;;;;;;;;;;;;;;;;;; (defun is_builtin_operator fexpr (l) ;;;;;;;;;;;;;;;;;;; (let* ((adaname (first l)) ; name of the Ada function. (lispname (implode (exploden (second l)))) ; name of lisp function to call. (params (third l)) ; list of parameter triples (returntype (ada_declared `(lex_ident ,(uplowlist (exploden (fourth l)))) nil 'type)) ; the typemark for returned type. (idrep `(lex_ident ,(uplowlist (exploden (first l))))) (sdrep `(lex_string ,(uplowlist (exploden (first l))))) (*bnl* 0) (*pnl* 0) (others (ada_declared idrep nil 'function t)) (nubody (sc_diana dn_predefined_function ct_lisp_func lispname)) (nuspec (sc_diana dn_function as_param_s (build_parameters params) as_name_void returntype ))) ;;now we need to find the matching stub, and fix in the body. (setq others (mapcan #'(lambda (fun) (cond ((eq (diana_nodetype_get (diana_get fun 'sm_body)) 'dn_stub) (list fun)))) others)) ; (break look-at-others) (setq others (with_same_type_profile (sc_diana dn_function_id ; this is a function id. lx_symrep idrep sm_body nubody sm_spec nuspec) others)) (cond ((> (length others) 1)(break cant-resolve-bif)) ((< (length others) 1)(break no-matching-bif-spec))) ; (break look-at-others) (diana_put (first others) nubody 'sm_body) ; (diana_put (first others) *pnl* 'ct_pnl) )) (declare (special default)) ;;;;;;;;;;;;;;;; (defun build_parameters(p) ;;;;;;;;;;;;;;;; (mapcar (function (lambda(ap) ; a parameter. (let ((mode (ada_param%mode ap)) (name (ada_param%name ap)) (type (ada_param%type ap)) (default (ada_param%default ap))) (let ((nodnam (concat 'dn_ mode)) (nodidnam (concat (concat 'dn_ mode) '_id))) (eval `(sc_diana ,nodnam as_exp_void nil as_name ',(first (ada_declared `(lex_ident ,(uplowlist (exploden type))) nil 'type ;nil t)) as_id_s (list (let ((pid (sc_diana ,nodidnam sm_obj_type ',(first (ada_declared `(lex_ident ,(uplowlist (exploden type))) nil 'type ;nil t)) lx_symrep '(lex_ident ,(uplowlist (exploden name)))))) (diana_put pid pid 'sm_defn) pid)) )))))) p) ) ;;;;;;;;;;;;;;;;;;;;;;;;; (defun build_parameters_internal (p) ;;;;;;;;;;;;;;;;;;;;;;;;; (mapcar #'(lambda(ap) ; a parameter. (let ((name (ada_param%name ap)) (type (ada_param%type ap)) ; (default (ada_param%default ap)) (dn (sc_diana dn_in as_exp_void nil))) (diana_put dn (list (let ((pid (sc_diana dn_in_id sm_obj_type type lx_symrep `(lex_ident ,(uplowlist (exploden name)))))) (diana_put pid pid 'sm_defn) pid)) 'as_id_s) (diana_put dn type 'as_name) dn)) p)) ;;; creates builtin enumeration types. ;;; eg . (is_ada_enumeration_type foo ((fred 1)(spam 2))) ;;; each literal is a triple (name position representation) ;;; the third may be omitted. ;;;;;;;;;;;;;;;;;;;;;;; (defun is_ada_enumeration_type fexpr (l) ;;;;;;;;;;;;;;;;;;;;;;; (let* ((type_id `(lex_ident ,(uplowlist (exploden (first l))))) (literals (mapcar #'(lambda(enum_lit) (let ((enum_id `(lex_ident ,(uplowlist (exploden (first enum_lit))))) (enum_pos (second enum_lit)) (enum_rep (third enum_lit))) (add_name enum_id 'object (eval `(sc_diana dn_enum_id lx_symrep ',enum_id sm_pos ',enum_pos sm_rep ',enum_rep)) nil))) (second l))) (enum_spec (sc_diana dn_enum_literal_s as_list literals))) ;; retroactively put in the type_spec fields. (mapc #'(lambda(enid) (diana_put enid enum_spec 'sm_obj_type)) literals) ;; now add the new type to the directory. (add_name type_id 'type (sc_diana dn_type_id lx_symrep type_id sm_type_spec enum_spec) nil))) ;;;;;;;;;;; (defun is_ada_type macro (l) ;;;;;;;;;;; `(add_name '(lex_ident ,(uplowlist (exploden (second l)))) 'type (sc_diana dn_predefined_type lx_symrep '(lex_ident ,(uplowlist (exploden (second l))))) nil)) ;;;;;;;;;;;;;; (defun is_ada_subtype macro (l) ;;;;;;;;;;;;;; `(add_name '(lex_ident ,(uplowlist (exploden (second l)))) 'type (sc_diana dn_subtype_id lx_symrep '(lex_ident ,(uplowlist (exploden (second l)))) sm_type_spec (sc_diana dn_constrained as_name (ada_declared '(lex_ident ,(uplowlist (exploden (third l)))) nil 'type))) nil)) ;;;;;;;;;;;;;;; (defun is_derived_type macro (l) ;;;;;;;;;;;;;;; `(add_name '(lex_ident ,(uplowlist (exploden (second l)))) 'type (sc_diana dn_type_id sm_type_spec (sc_diana dn_derived as_constrained (sc_diana dn_constrained as_constraint (sc_diana dn_void) as_name (ada_declared '(lex_ident ,(uplowlist (exploden (third l)))) nil 'type)) ) lx_symrep '(lex_ident ,(uplowlist (exploden (second l))))) nil)) ;;;;;;;;;;;;;;;; (defun is_ada_exception macro (l) ;;;;;;;;;;;;;;;; `(add_name '(lex_ident ,(uplowlist (exploden (second l)))) 'exception (sc_diana dn_predefined_exception) nil)) ;;;;;;;;;;;;; (defun is_ada_pragma macro (l) ; inserts pragma names in the symbol table. ;;;;;;;;;;;;; `(add_name '(lex_ident ,(uplowlist (exploden (second l)))) 'pragma ; this is a pragma. (sc_diana dn_predefined_pragma) nil)) ;;;;;;;;;;;;;;;;;;; (defun is_pragma_parameter macro (l) ; inserts pragma names in the symbol table. ;;;;;;;;;;;;;;;;;;; `(add_name '(lex_ident ,(uplowlist (exploden (second l)))) 'pragma_parameter; this is a pragma. ,`(sc_diana dn_predefined_pragma_parameter ct_for ',(third l)) nil)) ;;;;;;;;;;;;;;;; (defun is_ada_attribute macro(l); inserts attribute names in the symbol ;;;;;;;;;;;;;;;; ; table. `(add_name '(lex_ident ,(uplowlist (exploden (second l)))); the name. ',(third l) ; the type of attribute. (sc_diana dn_predefined_attribute) nil ; will be type info. )) ;;;;;;;;;;;;; (defun is_ada_syntax macro (l) ; hangs syntax onto property lists. ;;;;;;;;;;;;; `(progn 'compile (defprop ,(cadr l) ,(caddr l) ada_syntax) (defprop ,(cadr l) non_terminal syntax_type))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Call-able Functions/Macros -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Macros -- ;;;;;;;;;;;;;;;;;;;; (defun build_char_rep_array () ;;;;;;;;;;;;;;;;;;;; ;;; create the array ;;; fill the array ;;; #+lispm (fillarray **array_of_chars** **ct_ada_chars**) #+franz (do ((i 0 (1+ i)) (el **ct_ada_chars** (cdr el))) ((equal i 128) ) (store (**array_of_chars** i) (car el)))) ;;;;;;;;;;;;;;;;;;;;;;; (defun convert_integer_to_char (rep) ;;;;;;;;;;;;;;;;;;;;;;; #+lispm (aref **array_of_chars** rep) #+franz (arraycall t '**array_of_chars** rep )) ;;;;;;;;;;;;;;;;;;;;;;; (defun convert_char_to_integer (char) ;;;;;;;;;;;;;;;;;;;;;;; (cond ((eq char '*unassigned*) 32) (t (diana_get char 'sm_pos)))) ;;;;;;;;;;;;;;;;; (defun build_cache_array () ;;;;;;;;;;;;;;;;; (let ((nuarray #+franz (let ((arrnam (gensym))) (*array arrnam t 5000)(getd arrnam)) #+lispm (make-array (list 5000)))) (do ((i 0 (1+ i))) ((= i 5000) nuarray) #+franz (set (arrayref nuarray i) (cache nil nil nil)) #+lispm (aset (cache nil nil nil) nuarray i)))) ;;;Sets up the predefined standard environment for the parser. ;;;;;;;;;;; (defun init_syntax() ;;;;;;;;;;; ;;; First of all setup the global variables. (let ((*pnl* 0) (*bnl* 0)) (makunbound '*character_type*) (setq *package_standard* nil) ;;; these will convert char to integers and viceversa ;;; necessary for character handling ;;; This will now use an array look-up on a global array/mnt ;;; containing the dn-enum-id ;;; first need to build that array #+franz (array **array_of_chars** t 128) #+lispm (setq **array_of_chars** (make-array 128)) (setq *cache_on* t) (setq *ds_cache* (build_cache_array) *ds_cache_size* 4096) (setq la_srcpos 0 la_linpos 0 la_comments nil *preparsecc* 0 *postparsecc* 0) (setq *contextstack* nil) (setq *identstack* nil) ; a stack used to match loop and subprog (setq **current_block** nil) ; setup top of environment. (setq **standard_env** (setq **current_block** (new_block))) (setq *inbuilt_diana_trees* nil) #| ;;; This is a temporary hack as an interim measure to fix text_io. (add_name ; add library-unit text_io `(lex_ident ,(uplowlist (exploden 'text_io))) 'library_unit (la_id `(lex_ident ,(uplowlist (exploden 'text_io)) ) 0 nil nil 'library_unit 'library_unit nil) (sc_diana dn_frig_id lx_symrep `(lex_ident ,(uplowlist (exploden 'text_io)) )) nil) ;;; #+frig --it was in for round two.. lets put it in again for round three! (add_name ; add package text_io `(lex_ident ,(uplowlist (exploden 'text_io))) 'package (la_id `(lex_ident ,(uplowlist (exploden 'text_io)) ) 0 nil nil 'package 'package nil) (sc_diana dn_frig_id lx_symrep `(lex_ident ,(uplowlist (exploden 'text_io)) )) nil) ;;; End of temporary hack. |# ;;; Predefined enumeration types. (is_ada_type **any_type**) (is_ada_enumeration_type boolean ((false 0)(true 1))) (setq *ct_ada_true* ; get truth value (let ((id (exploden '|true|))) (fourth (first (get_id `(lex_ident ,id) (la_hash id)))))) (setq *ct_ada_false* ; get truth value (let ((id (exploden '|false|))) (fourth (first (get_id `(lex_ident ,id) (la_hash id)))))) ;;; Define the predefined pragmas. (is_ada_pragma controlled) (is_ada_pragma elaborate) (is_ada_pragma inline) (is_ada_pragma interface) (is_ada_pragma list) (is_ada_pragma memory_size) (is_ada_pragma optimize) (is_ada_pragma pack) (is_ada_pragma page) (is_ada_pragma priority) (is_ada_pragma storage_unit) (is_ada_pragma suppress) (is_ada_pragma system_name) (is_ada_pragma lisp_call) ; very temporary hackeroo!! (is_ada_pragma annotate) ; did someone say that this was a crock? ;;; The Predefined pragma parameters. (is_pragma_parameter range_check suppress) (is_pragma_parameter index_check suppress) (is_pragma_parameter on list) (is_pragma_parameter off list) ;(is_pragma_parameter time optimize) (is_pragma_parameter space optimize) (is_pragma_parameter lisp interface) ;;; Define the Ada Attributes. (is_ada_attribute address not_indexable_attribute) (is_ada_attribute aft not_indexable_attribute) (is_ada_attribute base not_indexable_attribute) (is_ada_attribute callable not_indexable_attribute) (is_ada_attribute constrained not_indexable_attribute) (is_ada_attribute count not_indexable_attribute) (is_ada_attribute delta not_indexable_attribute) (is_ada_attribute digits not_indexable_attribute) (is_ada_attribute emax not_indexable_attribute) (is_ada_attribute epsilon not_indexable_attribute) (is_ada_attribute first indexable_attribute) (is_ada_attribute first_bit not_indexable_attribute) (is_ada_attribute fore not_indexable_attribute) (is_ada_attribute image not_indexable_attribute) (is_ada_attribute large not_indexable_attribute) (is_ada_attribute last indexable_attribute) (is_ada_attribute last_bit not_indexable_attribute) ; (is_ada_attribute length not_indexable_attribute) (is_ada_attribute length indexable_attribute) (is_ada_attribute machine_emax not_indexable_attribute) (is_ada_attribute machine_emin not_indexable_attribute) (is_ada_attribute machine_mantissa not_indexable_attribute) (is_ada_attribute machine_overflows not_indexable_attribute) (is_ada_attribute machine_radix not_indexable_attribute) (is_ada_attribute machine_rounds not_indexable_attribute) (is_ada_attribute mantissa not_indexable_attribute) (is_ada_attribute pos not_indexable_attribute) (is_ada_attribute position not_indexable_attribute) (is_ada_attribute pred not_indexable_attribute) (is_ada_attribute range indexable_attribute) (is_ada_attribute safe_emax not_indexable_attribute) (is_ada_attribute safe_large not_indexable_attribute) (is_ada_attribute safe_small not_indexable_attribute) (is_ada_attribute size not_indexable_attribute) (is_ada_attribute small not_indexable_attribute) (is_ada_attribute storage_size not_indexable_attribute) (is_ada_attribute succ not_indexable_attribute) (is_ada_attribute terminated not_indexable_attribute) (is_ada_attribute val not_indexable_attribute) (is_ada_attribute value not_indexable_attribute) (is_ada_attribute width not_indexable_attribute) ;;; Predefined Types. (is_ada_type **any_real**) ;provide inheritance for ;fixed and float types. ; (is_ada_type **any_fixed**) ;provide inheritance for fixed types. (is_ada_type **any_integer**) ;ditto integer; ; (is_ada_type **any_float**) ;ditto float. (is_derived_type integer **any_integer**) (is_derived_type **any_fixed** **any_real**) (is_derived_type **any_float** **any_real**) (is_ada_subtype float **any_float**) (setq *universal_integer* (ada_declared (ada_ident **any_integer**) nil 'type nil)) (setq *universal_real* (ada_declared (ada_ident **any_real**) nil 'type nil)) (setq *universal_fixed* (ada_declared (ada_ident **any_fixed**) nil 'type nil)) (setq *universal_float* (ada_declared (ada_ident **any_float**) nil 'type nil)) (setq *universal_types* (list *universal_real* *universal_fixed* *universal_integer*)) ;;; (is_ada_type character) ;;; (is_ada_type string) ;;; Predefined Subtypes ;;; (is_ada_subtype natural integer) ; * ;;; (is_ada_subtype positive integer) ; * (init_old_operators) ;;; Load in the standard package by reading it in through the frontend. ;;; bootstrap the frontend with the wazzoo principle. (with_open_infile (pkgstd (ct_load_get 'stdpkg)) (let* ((*path* (ct_load_get 'stdpkg)) (frob (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (setq *inbuilt_diana_trees* (union *inbuilt_diana_trees* (diana_get frob 'as_list))))) ;;; Grab the package standard context and make it the standard environment ;;; to simulate a 'with standard; use standard' (internalize_package 'standard) ;;now get a hold of the character enumeration literals. (setq **ct_ada_chars** (diana_get (diana_get (first (ada_declared (ada_ident character) nil 'type t)) 'sm_type_spec) 'as_list)) (setq *character_type* (ada_declared (ada_ident character) nil 'type)) (setq *integer_type* (ada_declared (ada_ident integer) nil 'type)) (setq *float_type* (ada_declared (ada_ident float) nil 'type)) (build_char_rep_array ) ;;; These will be defined in std_pkg.ada ;;; Predefined Exceptions. ;;; (is_ada_exception constraint_error) ;;; (is_ada_exception numeric_error) ;;; (is_ada_exception program_error) ;;; (is_ada_exception storage_error) ;;; (is_ada_exception tasking_error) (init_operators) ;; internalizing the system package and the text_io package (with_open_infile (pkgstd (ct_load_get 'syspkg)) (let* ((*path* (ct_load_get 'syspkg)) (frob (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (setq *inbuilt_diana_trees* (union *inbuilt_diana_trees* (diana_get frob 'as_list))))) (with_package system (setq *address_type* (ada_declared (ada_ident address) nil 'type))) (with_open_infile (pkgstd (ct_load_get 'ioexpkg)) (let* ((*path* (ct_load_get 'ioexpkg)) (frob (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (setq *inbuilt_diana_trees* (union *inbuilt_diana_trees* (diana_get frob 'as_list))))) (with_open_infile (pkgstd (ct_load_get 'textiop)) (let* ((*path* (ct_load_get 'textiop)) (frob (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (setq *inbuilt_diana_trees* (union *inbuilt_diana_trees* (diana_get frob 'as_list))))) (initialize_text_io) (cond ((not (status feature *kneecapped*)) (with_open_infile (pkgstd (ct_load_get 'seqiop)) (let* ((*path* (ct_load_get 'seqiop))) (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (initialize_seq_io))) (cond ((not (status feature *kneecapped*)) (with_open_infile (pkgstd (ct_load_get 'diriop)) (let* ((*path* (ct_load_get 'diriop))) (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (initialize_dir_io))) (cond ((not (status feature *kneecapped*)) (with_open_infile (pkgstd (ct_load_get 'calendp)) (let* ((*path* (ct_load_get 'calendp))) (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (initialize_calendar))) ;;; Predefined procedures. go into the standard package too. (with_open_infile (pkgstd (ct_load_get 'ctbasio)) (let* ((*path* (ct_load_get 'ctbasio)) (frob (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (setq *inbuilt_diana_trees* (union *inbuilt_diana_trees* (diana_get frob 'as_list))))) (cond ((status feature report) (with_open_infile (pkgstd (ct_load_get 'repspec)) (let* ((*path* (ct_load_get 'repspec)) (frob (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (setq *inbuilt_diana_trees* (union *inbuilt_diana_trees* (diana_get frob 'as_list))))) (with_open_infile (pkgstd (ct_load_get 'repbody)) (let* ((*path* (ct_load_get 'repbody)) (frob (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (setq *inbuilt_diana_trees* (union *inbuilt_diana_trees* (diana_get frob 'as_list))))) (with_open_infile (pkgstd (ct_load_get 'chkfile)) (let* ((*path* (ct_load_get 'chkfile)) (frob (ada_int_inc pkgstd (terminal_output) (terminal_output) (terminal_output) (terminal_output) (terminal_output)))) (setq *inbuilt_diana_trees* (union *inbuilt_diana_trees* (diana_get frob 'as_list))))))) )) ;;;;;;;;;;;;;;;;;; (defun init_old_operators() ;;;;;;;;;;;;;;;;;; (old_is_new_builtin_operator rem |int_rem| ((in left **any_integer**)(in right **any_integer**) ) **any_integer**) (old_is_builtin_operator **any_equal** |any_equal| ((in left **any_type**)(in right **any_type**) ) boolean) (old_is_new_builtin_operator mod |int_mod| ((in left **any_integer**)(in right **any_integer**) ) **any_integer**) (old_is_new_builtin_operator abs |int_abs| ((in right **any_integer**) ) **any_integer**) (old_is_new_builtin_operator abs |float_abs| ((in right **any_float**) ) **any_float**) (old_is_new_builtin_operator * |int_times| ((in left **any_integer**)(in right **any_integer**)) **any_integer**) (old_is_new_builtin_operator + |int_plus| ((in left **any_integer**)(in right **any_integer**)) **any_integer**) (old_is_new_builtin_operator - |int_minus| ((in left **any_integer**)(in right **any_integer**)) **any_integer**) (old_is_new_builtin_operator - |int_uminus| ((in right **any_integer**)) **any_integer**) (old_is_new_builtin_operator + |int_uplus| ((in right **any_integer**)) **any_integer**) (old_is_new_builtin_operator !/ |int_divide| ((in left **any_integer**)(in right **any_integer**)) **any_integer**) (old_is_new_builtin_operator ** |int_exp| ((in left **any_integer**)(in right **any_integer**)) **any_integer**) (old_is_new_builtin_operator + |float_plus| ((in left **any_float**)(in right **any_float**)) **any_float**) (old_is_new_builtin_operator - |float_minus| ((in left **any_float**)(in right **any_float**)) **any_float**) (old_is_new_builtin_operator !/ |float_divide| ((in left **any_float**)(in right **any_float**)) **any_float**) (old_is_new_builtin_operator * |float_times| ((in left **any_float**)(in right **any_float**)) **any_float**) (old_is_new_builtin_operator ** |float_exp| ((in left **any_float**)(in right **any_integer**)) **any_float**) (old_is_new_builtin_operator - |float_uminus| ((in right **any_float**)) **any_float**) (old_is_new_builtin_operator + |float_uplus| ((in right **any_float**)) **any_float**) (old_is_new_builtin_operator = |int_equal| ((in left **any_integer**)(in right **any_integer**)) boolean) ; (old_is_builtin_operator !/= |int_not_equal| ; ((in left **any_integer**)(in right **any_integer**)) ;boolean) (old_is_new_builtin_operator < |int_less_than| ((in left **any_integer**)(in right **any_integer**)) boolean) (old_is_new_builtin_operator > |int_greater_than| ((in left **any_integer**)(in right **any_integer**)) boolean) (old_is_new_builtin_operator <= |int_less_than_or_eq| ((in left **any_integer**)(in right **any_integer**)) boolean) (old_is_new_builtin_operator >= |int_greater_than_or_eq| ((in left **any_integer**)(in right **any_integer**)) boolean) (old_is_new_builtin_operator = |float_equal| ((in left **any_float**)(in right **any_float**)) boolean) ; (old_is_builtin_operator !/= |float_not_equal| ; ((in left float)(in right float)) boolean) (old_is_new_builtin_operator < |float_less_than| ((in left **any_float**)(in right **any_float**)) boolean) (old_is_new_builtin_operator > |float_greater_than| ((in left **any_float**)(in right **any_float**)) boolean) (old_is_new_builtin_operator <= |float_less_than_or_eq| ((in left **any_float**)(in right **any_float**)) boolean) (old_is_new_builtin_operator >= |float_greater_than_or_eq| ((in left **any_float**)(in right **any_float**)) boolean) (old_is_builtin_operator * |uni_int_real_times| ((in left **any_integer**)(in right **any_real**)) **any_real**) (old_is_builtin_operator * |uni_real_int_times| ((in left **any_real**)(in right **any_integer**)) **any_real**) (old_is_builtin_operator !/ |uni_real_int_divide| ((in left **any_real**)(in right **any_integer**)) **any_real**) (old_is_builtin_operator + |fixed_point_plus| ((in left **any_fixed**)(in right **any_fixed**)) **any_fixed**) (old_is_builtin_operator - |fixed_point_minus| ((in left **any_fixed**)(in right **any_fixed**)) **any_fixed**) (old_is_builtin_operator !/ |fixed_point_divide| ((in left **any_fixed**)(in right **any_fixed**)) **any_fixed**) (old_is_builtin_operator * |fixed_point_times| ((in left **any_fixed**)(in right **any_fixed**)) **any_fixed**) (old_is_builtin_operator + |fixed_point_uplus| ((in right **any_fixed**)) **any_fixed**) (old_is_builtin_operator abs |fixed_point_abs| ((in right **any_fixed**)) **any_fixed**) (old_is_builtin_operator - |fixed_point_uminus| ((in right **any_fixed**)) **any_fixed**) (old_is_builtin_operator = |fixed_point_equal| ((in left **any_fixed**)(in right **any_fixed**)) boolean) (old_is_builtin_operator !/= |fixed_point_not_equal| ((in left **any_fixed**)(in right **any_fixed**)) boolean) (old_is_builtin_operator < |fixed_point_less_than| ((in left **any_fixed**)(in right **any_fixed**)) boolean) (old_is_builtin_operator <= |fixed_point_less_than_or_equal| ((in left **any_fixed**)(in right **any_fixed**)) boolean) (old_is_builtin_operator > |fixed_point_greater_than| ((in left **any_fixed**)(in right **any_fixed**)) boolean) (old_is_builtin_operator >= |fixed_point_greater_than_or_equal| ((in left **any_fixed**)(in right **any_fixed**)) boolean) ) ;;;;;;;;;;;;;; (defun init_operators() ;;;;;;;;;;;;;; ; (is_new_builtin_operator **any_not_equal** |any_not_equal| ; ((in left **any_type**)(in right **any_type**) ) boolean) (is_new_builtin_operator not |bool_not| ((in right boolean) ) boolean) (is_new_builtin_operator and |bool_and| ((in left boolean)(in right boolean) ) boolean) (is_new_builtin_operator or |bool_or| ((in left boolean)(in right boolean) ) boolean) (is_new_builtin_operator xor |bool_xor| ((in left boolean)(in right boolean) ) boolean) (is_new_builtin_operator = |bool_equal| ((in left boolean)(in right boolean)) boolean) ; (is_new_builtin_operator !/= |bool_not_equal| ; ((in left boolean)(in right boolean)) boolean) (is_new_builtin_operator < |bool_less_than| ((in left boolean)(in right boolean)) boolean) (is_new_builtin_operator > |bool_greater_than| ((in left boolean)(in right boolean)) boolean) (is_new_builtin_operator <= |bool_less_than_or_eq| ((in left boolean)(in right boolean)) boolean) (is_new_builtin_operator >= |bool_greater_than_or_eq| ((in left boolean)(in right boolean)) boolean) (is_new_builtin_operator = |string_equal| ((in left string)(in right string)) boolean) ; (is_new_builtin_operator !/= |string_not_equal| ; ((in left string)(in right string)) boolean) (is_new_builtin_operator < |string_less_than| ((in left string)(in right string)) boolean) (is_new_builtin_operator > |string_greater_than| ((in left string)(in right string)) boolean) (is_new_builtin_operator <= |string_less_than_or_eq| ((in left string)(in right string)) boolean) (is_new_builtin_operator >= |string_greater_than_or_eq| ((in left string)(in right string)) boolean) (is_new_builtin_operator & |string_&ss| ((in left string)(in right string)) string) (is_new_builtin_operator & |string_&sc| ((in left string)(in right character)) string) (is_new_builtin_operator & |string_&cs| ((in left character)(in right string)) string) (is_new_builtin_operator & |string_&cc| ((in left character)(in right character)) string) ) ;;; Define the static semantics for each of the predefined pragmas. ;;;;;;;;;;; (defun |pragma_list|(args) ; switch on/off the listing. ;;;;;;;;;;; (let ((what (intern (implode (cadr (diana_get (first args) 'lx_symrep))) 'user))) (cond ((and (eq what '|on|) (null *produce_listing*)) (%= *listing_switch* 2)) ((and *produce_listing* (null (eq what '|on|))) (%= *listing_switch* 0)))) ) ;;;;;;;;;;;;;;; (defun |pragma_optimize|(args) ; specify optimization for time or space ;;;;;;;;;;;;;;; ) ;;;;;;;;;;;;;;;; (defun |pragma_interface|(args) ; interface to specified language (lisp) ;;;;;;;;;;;;;;;; (let ((language (implode (cadr (diana_get (first args) 'lx_symrep)))) (funct (intern (implode (cadr (diana_get (second args) 'lx_symrep))) 'user)) (functnam (diana_get (second args) 'sm_defn))) (putprop (cdr functnam) `(dn_ct_lispcall () ct_function ,funct) 'sm_body) ; define the body as a lisp call. ) ) ;;;;;;;;;;;;;;;;; (defun |pragma_controlled|(args) ; dont garbage collect specified access type. ;;;;;;;;;;;;;;;;; nil) ;;;;;;;;;;;;;;;; (defun |pragma_elaborate|(args) ; elaborate specified secondary unit. ;;;;;;;;;;;;;;;; nil) ;;;;;;;;;;;;; (defun |pragma_inline|(args) ; nonesensicle for direct diana interpreter. ;;;;;;;;;;;;; nil) ;;;;;;;;;;;;;;;;;; (defun |pragma_memory_size|(args) ; specify memory size! ;;;;;;;;;;;;;;;;;; nil) ;;;;;;;;;;; (defun |pragma_pack|(args) ; storage is important here ;;;;;;;;;;; nil) ;;;;;;;;;;; (defun |pragma_page|(args) ; newpage listing. ;;;;;;;;;;; (%= *la_newpages* (1+ *_*)) ) ;;;;;;;;;;;;;;; (defun |pragma_priority|(args) ; specify task priority ;;;;;;;;;;;;;;; nil) (defun |pragma_storage_unit|(args); specify size of storage unit in bits. nil) ;;;;;;;;;;;;;;; (defun |pragma_suppress|(args) ; dont check specified check. ;;;;;;;;;;;;;;; nil) ;;;;;;;;;;;;;;;;;; (defun |pragma_system_name|(args) ; specify system. ;;;;;;;;;;;;;;;;;; nil) ;;;;;;;;;;;;;;;; (defun |pragma_lisp_call|(args) nil) ; no static semantics. ;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;; (defun |pragma_annotate|(args) nil) ; no static semantics. ;;;;;;;;;;;;;;;