;;; -*- Mode: Common-Lisp; Base: 8; Package: SI -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1985, 1986,1987 Texas Instruments Incorporated. All rights reserved.

;;; This file contains the base version of the system definition
;;; functions for use during system operation.  Special systems such
;;; as the cold load generator and the microcode assembler may define
;;; their own version of these functions to get similar but different
;;; action.

;;; Edit history:
;;;------------------------------------------------------------------------------
;;;  8-26-87  rjf           o Ran thru translater and changed to common-lisp mode 
;;;  10/22/87 PHD           o Added code in defenum and defalternate to
;;;                           preserve the fact that some parameters are constant.

(DEFMACRO DEFSYSCONST (SYMBOL VALUE &OPTIONAL DOCUMENTATION)
  `(eval-when (load eval compile)
     (DEFparameter ,SYMBOL ,VALUE ,DOCUMENTATION)
     ,@(ADD-PROPERTIES SYMBOL '(SYSTEM-CONSTANTS)))) 

(DEFMACRO DEFSYSVAR (SYMBOL VALUE &OPTIONAL DOCUMENTATION)
  `(DEFVAR ,SYMBOL ,VALUE ,DOCUMENTATION)) 


(DEFMACRO DEFENUM (HEADER PROPERTIES ENUMERATION-LIST)
  (LET* ((NAME (IF (ATOM HEADER)
		 HEADER
		 (CAR HEADER)))
	 (INIT (IF (OR (ATOM HEADER) (< (LENGTH HEADER) 2))
		 0
		 (ZLC::EVAL (SECOND HEADER))))
	 (DELTA (IF (OR (ATOM HEADER) (< (LENGTH HEADER) 3))
		  1
		  (ZLC::EVAL (THIRD HEADER))))
	 (FIELD (IF (OR (ATOM HEADER) (< (LENGTH HEADER) 4))
		  NIL
		  (ZLC::EVAL (FOURTH HEADER))))
	 (FIELD-WIDTH (IF FIELD
			(LDB 6 FIELD)))
	 (NAME-LIST NIL))
    (DO ((ENUM ENUMERATION-LIST (CDR ENUM))
	 (VALUE INIT (+ VALUE DELTA))
	 (*FORMS* NIL))
	((NULL ENUM)
	 `(eval-when (eval load compile)
	    (,(if (getdecl name 'compiler:system-constant)
		  'defconstant
		  'DEFparameter) ,NAME ',(REVERSE NAME-LIST))
	    ,@(REVERSE *FORMS*)
	    ,@(ADD-PROPERTIES NAME PROPERTIES)
	    ,NAME))
	 ;; check value
      (IF (AND (NOT (NULL FIELD)) (> (HAULONG VALUE) FIELD-WIDTH))
	(FERROR NIL "Enumeration ~a exceeded maximum value ~d./~d." NAME VALUE
		(1- (EXPT 2 FIELD-WIDTH))))
      ;; Add the next definition.
      (LET ((ITEM-NAME (IF (ATOM (CAR ENUM))
			 (CAR ENUM)
			 (CAAR ENUM)))
	    (ITEM-PROP (IF (ZLC::LISTP (CAR ENUM))
			 (CDAR ENUM))))
	(PUSH ITEM-NAME NAME-LIST)
	(PUSH `(,(if (getdecl ITEM-NAME  'compiler:system-constant)
		     'DEFconstant
		     'defparameter) ,ITEM-NAME ,(IF FIELD
						    (DPB VALUE FIELD 0)
						    VALUE))
		  *FORMS*)
	(IF (NOT (NULL ITEM-PROP))
	  (SETQ *FORMS* (APPEND (ADD-PROPERTIES ITEM-NAME ITEM-PROP) *FORMS*))))))) 

(DEFMACRO DEFALTERNATE (SYMBOL PROPERTIES ALTERNATION-LIST)
  (DO ((LIST ALTERNATION-LIST (CDDR LIST))
       (ALTERNATES (CAR ALTERNATION-LIST) (CONS (CAR LIST) ALTERNATES))
       (*FORMS* NIL))
      ((NULL LIST)
       `(eval-when (eval load compile)
	  (,(if (getdecl symbol 'compiler:system-constant)
		  'defconstant
		  'DEFparameter) ,SYMBOL ',(REVERSE ALTERNATES))
	  ,@(REVERSE *FORMS*)
	  ,@(ADD-PROPERTIES SYMBOL PROPERTIES)))
    (PUSH `(,(if (getdecl (CAR LIST) 'compiler:system-constant)
		  'defconstant
		  'DEFparameter) ,(CAR LIST) ,(CADR LIST)) *FORMS*))) 
;;; Returns a list of forms which when evaluated will add SYMBOL to the
;;; lists represented by PROPERTIES.

(DEFUN ADD-PROPERTIES (SYMBOL PROPERTIES)
  (IF (NOT (NULL PROPERTIES))
    (DO ((PROPERTY PROPERTIES (CDR PROPERTY))
	 (*FORMS* NIL))
	((NULL PROPERTY)
	 *FORMS*)
      (PUSH `(ADD-PROPERTY ',SYMBOL ',(CAR PROPERTY)) *FORMS*)))) 

(DEFUN ADD-PROPERTY (SYMBOL LIST)
  (IF (NOT (BOUNDP LIST))
    (SET LIST NIL))
  (WHEN (NOT (ZLC:MEMQ SYMBOL (SYMBOL-VALUE LIST)))
    (PUSH SYMBOL (SYMBOL-VALUE LIST))))