% File: TRACE.LIB (c) 06/26/80 The Soft Warehouse %
   % Аргументами функции TRACE являются имена функций, кото-
   рые мы хотим трассировать. Трассировка содержит имена вы-
   зываемых  функций  и  аргументов  и возвращаемое значение
   после вычислений. Трассируются только функции, определен-
   ные с помощью LAMBDA и NLAMBDA %
   (PROG1 "" (PUTD DEFUN (QUOTE (NLAMBDA (FUNC DEF)
                                (PUTD FUNC DEF) FUNC ))) )
   % --------------------------------------------------- %
   (DEFUN TRACE (LAMBDA LST
      (SETQ INDENT 0)
      (MAPC LST (QUOTE (LAMBDA (FUN BODY FUN#)
         (SETQ BODY (GETD FUN))
         (SETQ FUN# (PACK (LIST FUN #)))
         (MOVD FUN FUN#)
         ((MEMBER (CAR BODY) (QUOTE (LAMBDA NLAMBDA)))
            (PUTD FUN (LIST (CAR BODY) (CADR BODY)
            (LIST EVTRACE FUN (CADR BODY) FUN#) )) )
         (PRIN1 FUN)
      (PRINT " is not a LAMBDA defined function") )) )
   ))
   % ---------------------- %
   (DEFUN UNTRACE (LAMBDA LST
   % Функция UNTRACE отменяет трассировку %
      (MAPC LST
          (QUOTE (LAMBDA (FUN FUN#)
                    (SETQ FUN# (PACK (LIST FUN #)))
                    ( (GETD FUN#) (MOVD FUN# FUN)
                                  (MOVD NIL FUN#) )
          ))
      )
   ))
   % ----------------------------------- %
   (DEFUN EVTRACE (NLAMBDA (FUN ARGS FUN#)
      (PRTARGS FUN ARGS)
      (PRTRSLT FUN (APPLY FUN# (MAKARGS ARGS)))
   ))
   % ----------------------------- %
   (DEFUN PRTARGS (LAMBDA (FUN ARGS)
      (SPACES INDENT)
      (SETQ INDENT (PLUS INDENT 1)) (PRIN1 FUN) (PRIN1 " [")
      ( (NULL ARGS) (PRINT "]") )
      ( LOOP
          ( (ATOM ARGS) (SETQ ARGS (EVAL ARGS))
             ( LOOP
                 (PRIN1 (CAR ARGS)) (SETQ ARGS (CDR ARGS))
                 ( (ATOM ARGS) ) (PRIN1 ", ")
             )
          )
          (PRIN1 (EVAL (CAR ARGS)))
          (SETQ ARGS (CDR ARGS))
          ( (NULL ARGS) )
          (PRIN1 ", ")
      )
      (PRINT "]")
    ))
   % ----------------------------- %
   (DEFUN PRTRSLT (LAMBDA (FUN RSLT)
      (SETQ INDENT (DIFFERENCE INDENT 1)) (SPACES INDENT)
      (PRIN1 FUN) (PRIN1 " = ") (PRINT RSLT) RSLT
   ))
   % ------------------------- %
   (DEFUN MAKARGS (LAMBDA (ARGS)
      ( (NULL ARGS) NIL)
      ( (ATOM ARGS) (EVAL ARGS) )
      (CONS (EVAL (CAR ARGS)) (MAKARGS (CDR ARGS)))
   ))
   % -------------------------- %
   (DEFUN MAPC (LAMBDA (LST FUNC)
      (LOOP
         ( (NULL LST) NIL)
         ( FUNC (CAR LST) )
         ( SETQ LST (CDR LST) )
     )
   ))
   (RDS)

   (DEFUN LIKE (LST)
   % Построение списка тех атомов из списка атомов LST, ко-%
   % торые в своем имени содержат русские буквы А, В, Е,   %
   % К, М, Н, О, Р, С, Т, Х, похожие  по  написанию  на    %
   % латинские                                             %
      (COND ( (NULL LST) NIL )
            ( (RUS_LETTER (UNPACK (CAR LST)))
                  (CONS (CAR LST) (LIKE (CDR LST))) )
            (  T  (LIKE (CDR LST)) )
      )
   )
   % -------------------- %
   (DEFUN  RUS_LETTER (LST)
   % Предикат, возвращающий T, если в имени атома встреча- %
   % ется одна из следующих русских букв:                  %
   %                  А В Е К М Н О Р С Т Х                %
      (COND ( (NULL LST) NIL )
            ( (MEMBER (CAR LST) '(А В Е К М Н О Р С Т Х)) T)
            (  T  (RUS_LETTER (CDR LST)) )
      )
   )