;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/bifmacs.l,v 1.18 84/08/02 11:19:29 pozsvath Exp $
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                             BIFMACS                              ;;;
;;; Paul Robertson                                        18-July-83 ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;; 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. ;;;
;;; 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 'ctflav)) 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
 (declare (ct_includef 'intrpdcl))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 


;;; Macros to ease the implementation of 'built in functions/procedures'
;;; Assumes that the appropriate activation record is in 'ar'

#|
(with_quick_ada_parameters ((foo bar)(fred spam))
		     (body goes here)
		     (and here))

(with_ada_parameters ((foo bar)(fred spam))
		     (body goes here)
		     (and here))
|#

       ;;;;;;;;;;;;;;;;;;;
(defun with_ada_parameters macro (l)
       ;;;;;;;;;;;;;;;;;;;
       (let ((paramlist (cadr l))	  ;parameters
	     (bifbod (cddr l)))		  ;body of the function.
	 ;;paramlist is a list of the form ((lispname adaname) .. .. ..)
	 `(let* ,(append (ada_to_lisp_parameters paramlist)
			 `((result ,@(blockify bifbod))))
	    . ,(append (lisp_to_ada_parameters paramlist) '(result)))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;
(defun with_quick_ada_parameters macro (l)
       ;;;;;;;;;;;;;;;;;;;;;;;;;
       (let ((paramlist (cadr l))	  ;parameters
	     (bifbod (cddr l)))		  ;body of the function.
	 ;;paramlist is a list of the form ((lispname adaname) .. .. ..)
	 `(let* ,(quick_ada_to_lisp_parameters paramlist)
	     ,@(blockify bifbod))))

       ;;;;;;;;;;;;;
(defun ada_parameter macro (l)
       ;;;;;;;;;;;;;
       (let ((param (second l)))
	 `(cdr (assoc_symrep
		 '(lex_ident ,(uplowlist (exploden param)))
		 (ct_send ar 'locals)))))

       ;;;;;;;;
(defun blockify (b)
       ;;;;;;;;
  (cond
    ((eq (length b) 1) b)
    (t `((progn ,@b)))))

       ;;;;;;;;;;;;;;;;;;;;;;
(defun ada_to_lisp_parameters (l)
       ;;;;;;;;;;;;;;;;;;;;;;
       (mapcar
	 #'(lambda(parampair)
	     (list (car parampair)
		   `(ct_send
		      (cdr (assoc_symrep
			     '(lex_ident ,(uplowlist (exploden (cadr parampair))))
			     (ct_send ar 'locals)))
		      'get_val nil)))
	 l))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun quick_ada_to_lisp_parameters (l)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   (do ((pairs l (cdr pairs))
	(pos 0 (1+ pos))
	(namelist nil))
       ((null pairs) namelist)
     (ct_push
       (list (caar pairs)
	     `(n_th ,pos ar))
       namelist)))



       ;;;;;;;;;;;;
(defun assoc_symrep (val lst)
       ;;;;;;;;;;;;

  (do ((item lst (cdr item)))
      ((null item) (lose 'be_map 'assoc_symrep))
    (cond
      ((equal val (diana_get (caar item) 'lx_symrep))
       (return (car item))))))

       ;;;;;;;;;;;;;;;;;;;;;;
(defun lisp_to_ada_parameters (l)
       ;;;;;;;;;;;;;;;;;;;;;;

  (mapcar
    #'(lambda(parampair)
	`(ct_send
	   (cdr (assoc_symrep
		  '(lex_ident ,(uplowlist (exploden (cadr parampair))))
		  (ct_send ar 'locals)))
	   'set_val nil ,(car parampair)))
    l))

       ;;;;;;;;;;;;;;;;;;;;;
(defun convert_lexstr_to_obj (lexstr)
       ;;;;;;;;;;;;;;;;;;;;;

  (let ((newobj (ct_make_instance 'dt_array_type)))
    (ct_send newobj 'set-array_storage nil)
    (ct_send newobj
	     'initialize_in_order_over_all_indices_to_aggregate lexstr)
    newobj))

       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun convert_strrep_to_lexstr (rep)
       ;;;;;;;;;;;;;;;;;;;;;;;;
  (cond ((consp rep) rep)
	(t
	 (let ((bounds (car (ct_send rep 'index_list))))
	   (list "lex_string" (extract_els
				rep
				(coerce_int (first bounds))
				(coerce_int (second bounds))))))))


       ;;;;;;;;;;
(defun extract_els (arrep lb ub)
       ;;;;;;;;;;
  
  (do  ((res nil)
        (index lb (1+ index)))
       ((greaterp index ub) (return (nreverse res)))
    (ct_push
      (convert_char_to_integer
	(ct_send
	  (ct_send  arrep 'get_val (list index))
	  'get_val nil))
      res)))


  
(defun convert_chrrep_to_lexchar (rep)
  (cond ((consp rep) rep)
	(t
	 (list "lex_char" (list (convert_char_to_integer rep))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;