Re: A style question

In article <C7fFh.6$M24.0@xxxxxxxxxxxx>,
Ken Tilton <kentilton@xxxxxxxxx> wrote:

Rainer Joswig wrote:
In article <1172658813.746823.247380@xxxxxxxxxxxxxxxxxxxxxxxxxxxx>,
"Tim Bradshaw" <tfb+google@xxxxxxxx> wrote:

Incidentally, I'm deeply disappointed in the quality of answers in
this thread. In the elder days there would have been at least a few
followups showing how to do this in the proper "FORMAT string
indistinguishable from line noise" way. No true CL programmer ever
uses any other construct when the problem can be solved with a
combination of FORMAT, LOOP & GO (FORMAT being always preferable,
obviously). There may yet be those reading cll who know this, though
I suspect they have all gone into the west now.


It is always a shock to me when I look at such code. I mean
many pages long functions full of GOs, two letter variables
and such (and zero comments). I cannot
believe that humans can write this code.

You refer of course to the Cello code to create a 3-D oblong button of
variable thickness with rounded corners of variable radius:

This code is harmless. It is not even UPPERCASE. Not enough global variables. Scroll down!


(defun ix-render-oblong (lbox thickness baser slices stacks)
(unless slices (setq slices 0))
(unless stacks (setq stacks (if (zerop thickness)
0 (min 10
(max 1 ;; force 3d if nonzero
thickness
(round (abs thickness) 2))))))
(when (eql (abs thickness) (abs baser))
(setf thickness (* .99 thickness)))
(trc nil "oblong" baser thickness etages)

(loop
with theta = (/ pi 2 slices)
with etages = stacks ;; french floors (etages) zero = ground floor
with lw/2 = (/ (r-width lbox) 2)
with lh/2 = (/ (r-height lbox) 2)
with bx = (- lw/2 baser)
with by = (- lh/2 baser)
for etage upto etages
for oe = 0 then ie
for ie = (unless (= etage etages)
(* (/ (1+ etage) etages)
(/ pi 2)))
for ii = (if (not ie)
0 ;; throwaway value to avoid forever testing if nil
(+ (* (abs thickness)
(- 1 (cos ie)))))

for ox = lw/2 then ix
for oy = lh/2 then iy
for oz = 0 then iz
for oc = (cornering baser slices) then ic
for ic = (when ie
(cornering (- baser ii) slices))
for ix = (- lw/2 ii)
for iy = (- lh/2 ii)
for iz = (when ie
(* thickness (sin ie)))

do (trc nil "staging" etage ie)


(gl-translatef (+ (r-left lbox) lw/2)(+ (r-bottom lbox) lh/2) 0)

(with-gl-begun ((if ie
gl_quad_strip
gl_polygon))

(loop for (dx dy no-turn-p)
in '((1 1)(-1 1)(-1 -1)(1 -1)(1 1 t))
;;for dbg = (and (eql dx 1)(eql dy 1)(not no-turn-p))
do (destructuring-bind (xyn0 ix0 iy0 ox0 oy0)
(cons (+ (if oc (/ theta 2) 0)
(ecase dx (1 (ecase dy (1 0)(-1 (/ pi -2))))
(-1 (ecase dy (1 (/ pi 2))(-1 pi)))))
(if oc
(case (* dx dy)
(1 (list (* dx ix)(* dy by)(* dx ox)(* dy by)))
(-1 (list (* dx bx)(* dy iy)(* dx bx)(* dy
oy))))
(list (* dx ix)(* dy iy)(* dx ox)(* dy oy))))

;; --- lay-down start/only -------------
(when ie
(ogl-vertex-normaling ie xyn0 ix0 iy0 iz))
(ogl-vertex-normaling oe xyn0 ox0 oy0 oz)

(trc nil "cornering!!!!!!----------------" dx dy)
;; --- corner if slices and not just finishing strip

(unless no-turn-p
(trc nil "------ start ------------------" (length
oc)(length ic))
(loop for (oxn . oyn) in oc
for icrem = ic then (cdr icrem)
for (ixn . iyn) = (car icrem)
for xyn upfrom (+ xyn0 theta) by theta
do (macrolet
((vtx (elev gx sx gy sy gz)
`(progn
(when (minusp (* dx dy))
(rotatef ,sx ,sy))
(ogl-vertex-normaling ,elev xyn
(incf ,gx (* dx ,sx))
(incf ,gy (* dy ,sy))
,gz))))
(trc nil "ocn icn" oxn oyn (car icrem))
(when icrem
(vtx ie ix0 ixn iy0 iyn iz))
(vtx oe ox0 oxn oy0 oyn oz)))))))
(gl-translatef (- (+ (r-left lbox) lw/2))
(- (+ (r-bottom lbox) lh/2)) 0)))

I always
think the author was some ugly 'Terminator' from the future,
though lately the Terminators seem to be blond and good looking.

Actually I was doing a rare transcription from a paper solution (where
short variables saved pencil lead).

kt

Take this (not written by me). Well, actually there are too many comments.
Though I'm not sure if they actually would help to understand the code...


(DEFUN INCREMENTAL-SEARCH (REVERSE-P)
(INITIALIZE-INCREMENTAL-SEARCH-GLOBALS)
(SELECT-WINDOW *WINDOW*) ;Flush typeout before TYPEIN-LINE-ACTIVATE
(TYPEIN-LINE "") ;Necessary if in the mini-buffer
(UNWIND-PROTECT
(TYPEIN-LINE-ACTIVATE
(SI:WITH-STACK-ARRAY
;; Allocate an skip-table on the stack to avoid consing too much.
;; We don't bother with the reoccurrence table because (1) it's size
;; changes for each pattern string, and (2) it's small anyway.
(SKIP-RESOURCE (HIGHEST-LEGAL-CHAR-CODE) :TYPE 'ART-FIXNUM)
(PROG (CHAR ; The current command.
REAL-CHAR ; The one to :UNTYI if need be
XCHAR ; Upcase version of character
MUST-REDIS ; T => The echo-area must be completely redisplayed.
(P 0) ; The stack pointer into *IS-BP*, etc. for input and rubout
(P1 0) ; The pointer for which search we are doing.
; Can never exceed P.
SUPPRESSED-REDISPLAY ; T if the last input char was read before
; redisplay had a chance to finish.
; A G read that way acts like a failing search quit.
(BP (POINT)) ; The POINT.
BP1 ; Aux BP used for actual searching.
NEW-BP
TIME-OUT ; Set by SEARCH when it times out so we can check input.
INPUT-DONE ; An altmode or control char has been seen.
; Do not look for input any more; just search, then exit.
(ORIG-PT) ; Original position of POINT.
(SKIP-TABLE NIL)
(OLD-SKIP-TABLE NIL)
(REOCCURRENCE-TABLE NIL)
(OLD-REOCCURRENCE-TABLE NIL)
)

(SETQ ORIG-PT (COPY-BP BP))
(SETQ BP1 (COPY-BP BP)) ; This is reused to save consing.
(STORE-ARRAY-LEADER 0 *IS-STRING* 0); Clear out the search string.
(ASET T *IS-STATUS* 0) ; Initialize the stacks.
(ASET REVERSE-P *IS-REVERSE-P* 0)
(ASET ':NORMAL *IS-OPERATION* 0)
(ASET 0 *IS-POINTER* 0)
(ASET (COPY-BP BP) *IS-BP* 0)
(SETQ MUST-REDIS T) ; Initially we must redisplay.
(GO CHECK-FOR-INPUT)

;; Come here if there is input, or nothing to do until there is input.
INPUT
(SETQ SUPPRESSED-REDISPLAY NIL)
(AND (WINDOW-READY-P *WINDOW*) ;In case of minibuffer
(REDISPLAY *WINDOW* ':POINT)) ; Redisplay point position while waiting.
(OR (= (WINDOW-REDISPLAY-DEGREE *WINDOW*) DIS-NONE)
(SETQ SUPPRESSED-REDISPLAY T))
(MULTIPLE-VALUE (CHAR REAL-CHAR)
(EDITOR-INPUT :SCROLL T :MOUSE :RETURN
:ANY-TYI 'COMMAND)) ; allow the mouse to work!
(UNLESS (CHARACTERP CHAR) ; eliminate mouse clicks now
(SETQ INPUT-DONE T)
;; This is admittedly a kludge, but it's the simplest way to
;; get EDITOR-INPUT to execute the mouse-clicked command
(SETQ *YANKED-MINI-BUFFER-COMMAND* CHAR)
(GO CHECK-FOR-INPUT))
(SETQ XCHAR (CHAR-UPCASE CHAR))
(COND ((NOT (OR (NOT (ZEROP (CHAR-BITS CHAR)))
(CHAR-EQUAL CHAR #\ALTMODE) (CHAR-EQUAL CHAR #\END)
(CHAR-EQUAL CHAR #\RUBOUT) (CHAR-EQUAL CHAR #\CLEAR-INPUT)
(CHAR-EQUAL CHAR #\HELP) (CHAR-EQUAL CHAR #\SCROLL)
(MEM #'CHAR-EQUAL CHAR TV:KBD-INTERCEPTED-CHARACTERS)))
(GO NORMAL))
((MEMQ XCHAR '(#\c-S #\c-R))
(PUSH-ISEARCH-STATUS)
(ASET ':REPEAT *IS-OPERATION* P)
(LET ((NEW-REVERSE-P (CHAR= XCHAR #\c-R)))
(COND ;; In reverse mode, just go to forward.
((NEQ (AREF *IS-REVERSE-P* P) NEW-REVERSE-P)
(ASET NEW-REVERSE-P *IS-REVERSE-P* P)
(SETQ MUST-REDIS T)
(ASET ':REVERSE *IS-OPERATION* P))
((ZEROP (AREF *IS-POINTER* P))
(LET ((STRING (STRING (OR (CAAR *SEARCH-RING*) (BARF)))))
(IF *RUBOUT-KILLS-LAST-SEARCH-STRING*
(PROGN
(COPY-ARRAY-CONTENTS STRING *IS-STRING*)
(ASET (ARRAY-ACTIVE-LENGTH STRING) *IS-POINTER* P))
(LOOP FOR MORE FIRST NIL THEN T
FOR CHAR BEING THE ARRAY-ELEMENTS OF STRING
WHEN MORE
DO (PUSH-ISEARCH-STATUS)
DO (LET ((IDX (AREF *IS-POINTER* P)))
(AND ( IDX (ARRAY-LENGTH *IS-STRING*))
(ADJUST-ARRAY-SIZE *IS-STRING* (+ IDX 100)))
(ASET CHAR *IS-STRING* IDX)
(ASET (1+ IDX) *IS-POINTER* P))
(ASET ':NORMAL *IS-OPERATION* P))))
(SETQ MUST-REDIS T))))
(GO CHECK-FOR-INPUT))
((CHAR= XCHAR #\c-Q)
(SETQ CHAR (MAKE-CHAR (EDITOR-INPUT)))
(GO NORMAL))
((CHAR= XCHAR #\c-G)
(COND ((AND (OR SUPPRESSED-REDISPLAY (NEQ (AREF *IS-STATUS* P) T))
(PLUSP P))
;; G in other than a successful search
;; rubs out until it becomes successful.
(SETQ P (DO ((P (1- P) (1- P)))
((EQ (AREF *IS-STATUS* P) T) P)))
(SETQ P1 (MIN P P1) MUST-REDIS T)
(GO CHECK-FOR-INPUT))
(T
(MOVE-POINT (AREF *IS-BP* 0))
(FUNCALL *TYPEIN-WINDOW* ':MAKE-COMPLETE)
(RETURN NIL))))
((MEMQ CHAR TV:KBD-INTERCEPTED-CHARACTERS)
(ZWEI-KBD-INTERCEPT-CHARACTER CHAR *TYPEIN-WINDOW*)
(GO CHECK-FOR-INPUT))
((OR (CHAR= CHAR #\ALTMODE) (CHAR= CHAR #\END))
(AND (ZEROP P)
(RETURN (LET ((*CURRENT-COMMAND* 'COM-STRING-SEARCH))
(COM-STRING-SEARCH-INTERNAL REVERSE-P NIL NIL NIL))))
(SETQ INPUT-DONE T)
(GO CHECK-FOR-INPUT))
((CHAR= CHAR #\RUBOUT)
(COND (( P 0) ; If he over-rubbed out,
(BEEP) ; that is an error.
(GO CHECK-FOR-INPUT))
(T
;; Rubout pops all of these PDLs.
(SETQ P (1- P))
(SETQ P1 (MIN P P1))
(SETQ MUST-REDIS T)
(GO CHECK-FOR-INPUT))))
((CHAR= CHAR #\CLEAR-INPUT)
(SETQ P 0 P1 0 MUST-REDIS T)
(GO CHECK-FOR-INPUT))
((CHAR= CHAR #\HELP)
(PRINT-DOC ':FULL *CURRENT-COMMAND*)
(FORMAT T "~2&Type any character to flush:")
(CHECK-FOR-TYPEOUT-WINDOW-TYPEOUT)
(GO CHECK-FOR-INPUT))
(T
(FUNCALL STANDARD-INPUT ':UNTYI REAL-CHAR)
(SETQ INPUT-DONE T)
(GO CHECK-FOR-INPUT)))
(FERROR NIL "A clause fell through.")

;; Normal chars to be searched for come here.
NORMAL
(OR MUST-REDIS (TYPEIN-LINE-MORE "~C" CHAR))
(PUSH-ISEARCH-STATUS)
(LET ((IDX (AREF *IS-POINTER* P)))
(AND ( IDX (ARRAY-LENGTH *IS-STRING*))
(ADJUST-ARRAY-SIZE *IS-STRING* (+ IDX 100)))
(WHEN (CHAR-FAT-P CHAR)
(UNLESS (STRING-FAT-P *IS-STRING*)
(LET ((NEW-STRING (MAKE-ARRAY (ARRAY-LENGTH *IS-STRING*)
:FILL-POINTER (FILL-POINTER *IS-STRING*)
:TYPE 'ART-FAT-STRING)))
(COPY-ARRAY-CONTENTS *IS-STRING* NEW-STRING)
(STRUCTURE-FORWARD *IS-STRING* NEW-STRING 2 2)
(SETQ *IS-STRING* NEW-STRING))))
(ASET CHAR *IS-STRING* IDX)
(ASET (1+ IDX) *IS-POINTER* P))
(ASET ':NORMAL *IS-OPERATION* P)
;; Come here after possibly processing input to update the search tables
;; to search for a while. First, if necessary and not suppressed
;; update the search string displayed in the echo area.
CHECK-FOR-INPUT
;; If there is input available, go read it.
;; Otherwise, do work if there is work to be done.
(AND (NOT INPUT-DONE)
(FUNCALL STANDARD-INPUT ':LISTEN)
(GO INPUT))
;; Now do some work for a while, then go back to CHECK-FOR-INPUT.
(COND (MUST-REDIS
(SETQ MUST-REDIS NIL)
(TYPEIN-LINE "~:|")
(OR (AREF *IS-STATUS* P1) (TYPEIN-LINE-MORE "Failing "))
(AND (AREF *IS-REVERSE-P* P) (TYPEIN-LINE-MORE "Reverse "))
(TYPEIN-LINE-MORE "I-Search: ")
(STORE-ARRAY-LEADER (AREF *IS-POINTER* P) *IS-STRING* 0)
(TYPEIN-LINE-MORE "~A" *IS-STRING*)))
;; Now see what sort of state the actual search is in, and
;; what work there is to do. P1 points at the level of the
;; table on which we are actually working.
(MOVE-BP BP1 (AREF *IS-BP* P1))
;; Display point at the end of the last search level which has succeeded.
(DO ((P0 P1 (1- P0)))
((EQ (AREF *IS-STATUS* P0) T)
(MOVE-POINT (AREF *IS-BP* P0))))
(MUST-REDISPLAY *WINDOW* DIS-BPS)
(COND ((EQ (AREF *IS-STATUS* P1) ':GO)

;; If we are about to repeat a search, generate the Boyer-Moore
;; tables for the pattern string and cache them. Do not generate
;; the tables if they are already cached.
(IF (OR TIME-OUT (CHAR= XCHAR #\c-S))
(WHEN (AND (NULL OLD-SKIP-TABLE) (NULL OLD-REOCCURRENCE-TABLE))
(SETQ OLD-SKIP-TABLE (GENERATE-BOYER-SKIP-TABLE
*IS-STRING* SKIP-RESOURCE)
OLD-REOCCURRENCE-TABLE (GENERATE-BOYER-REOCCURRENCE-TABLE
*IS-STRING*)))
(SETQ OLD-SKIP-TABLE NIL
OLD-REOCCURRENCE-TABLE NIL))
;; We need an additional check here, because of the interaction between
;; additional c-S'es and typeahead. If you type, say "FEPFS" c-S in a
;; long buffer with "FEP" at the beginning of the buffer and "FEPFS" at
;; the end of the buffer, then *IS-STRING* can get out of sync with the
;; reoccurrence table. This code gets them back in sync.
(WHEN (AND OLD-REOCCURRENCE-TABLE
( (ARRAY-LENGTH OLD-REOCCURRENCE-TABLE)
(STRING-LENGTH *IS-STRING*)))
(SETQ OLD-SKIP-TABLE (GENERATE-BOYER-SKIP-TABLE
*IS-STRING* SKIP-RESOURCE)
OLD-REOCCURRENCE-TABLE (GENERATE-BOYER-REOCCURRENCE-TABLE
*IS-STRING*)))
(SETQ SKIP-TABLE OLD-SKIP-TABLE
REOCCURRENCE-TABLE OLD-REOCCURRENCE-TABLE)

;; If the level we were working on is still not finished,
;; search at most 100 more lines. If we find it or the end of the buffer
;; before then, this level is determined and we can work on the next.
;; Otherwise, we remain in the :GO state and do 100 more lines next time.
(MULTIPLE-VALUE (NEW-BP TIME-OUT)
(SEARCH BP1 *IS-STRING*
(AREF *IS-REVERSE-P* P1) NIL 100
NIL *ALPHABETIC-CASE-AFFECTS-SEARCH* ;---
SKIP-TABLE REOCCURRENCE-TABLE))
;; What happened?
(COND (TIME-OUT
;; Nothing determined. NEW-BP has where we stopped.
(MOVE-BP BP1 NEW-BP))
((NULL NEW-BP)
;; This search was determined to be a failure.
(OR (AND (MEMQ ':MACRO-ERROR
(FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS))
(FUNCALL STANDARD-INPUT ':MACRO-ERROR))
(BEEP))
(ASET NIL *IS-STATUS* P1)
(MOVE-BP BP1 (AREF *IS-BP* (1- P1)))
(MOVE-POINT BP1)
(SETQ MUST-REDIS T))
(T ;; This search level has succeeded.
(ASET T *IS-STATUS* P1)
(MOVE-POINT NEW-BP)
(MOVE-BP BP1 NEW-BP))))
(( P P1)
;; This level is finished, but there are more pending levels typed ahead.
(SETQ P1 (1+ P1))
(ASET (SETQ BP1 (COPY-BP BP1)) *IS-BP* P1)
(STORE-ARRAY-LEADER (AREF *IS-POINTER* P1) *IS-STRING* 0)
(COND ((NULL (AREF *IS-STATUS* (1- P1)))
(COND ((NEQ (AREF *IS-OPERATION* P1) ':REVERSE)
;; A failing search remains so unless we reverse direction.
(ASET NIL *IS-STATUS* P1))
(T ;; If we reverse direction, change prompt line.
(SETQ MUST-REDIS T))))
((EQ (AREF *IS-OPERATION* P1) ':NORMAL)
;; Normal char to be searched for comes next.
;; We must adjust the bp at which we start to search
;; so as to allow the user to extend the string already found.
(MOVE-BP
BP1 (FORWARD-CHAR
BP1 (COND ((AREF *IS-REVERSE-P* P1)
(COND ((= (ARRAY-ACTIVE-LENGTH *IS-STRING*) 1)
0)
(T (ARRAY-ACTIVE-LENGTH *IS-STRING*))))
(T (- 1 (ARRAY-ACTIVE-LENGTH *IS-STRING*))))
T)))))
;; If there is nothing left to do, and terminator seen, exit.
(INPUT-DONE
(SEARCH-RING-PUSH
;; Entries on the search ring should have a leader
(STRING-NCONC (MAKE-ARRAY (ARRAY-ACTIVE-LENGTH *IS-STRING*)
':TYPE (ARRAY-TYPE *IS-STRING*)
':FILL-POINTER 0)
*IS-STRING*)
'SEARCH)
(TYPEIN-LINE-MORE "~C" #\END)
(MAYBE-PUSH-POINT ORIG-PT)
(SELECT-WINDOW *WINDOW*)
(RETURN NIL))
;; Nothing to do and no terminator, wait for input.
(T (GO INPUT)))
(GO CHECK-FOR-INPUT)

)))
(FUNCALL *MODE-LINE-WINDOW* ':DONE-WITH-MODE-LINE-WINDOW))
DIS-BPS)



How about this? This is clearly from aliens.


(DEFMFUN MEVAL1 (FORM)
(declare (special nounl *break-points* *break-step*))
(COND ((ATOM FORM)
(PROG (VAL)
(COND ((NOT (SYMBOLP FORM)) (RETURN FORM))
((AND $NUMER (SETQ VAL (SAFE-MGET FORM '$NUMER))
(OR (NOT (EQ FORM '$%E)) $%ENUMER))
(RETURN (MEVAL1 VAL)))
((NOT (BOUNDP FORM))
(IF (SAFE-GET FORM 'BINDTEST)
(MERROR "~:M unbound variable" FORM)
(RETURN FORM)))
((MFILEP (SETQ VAL (SYMBOL-VALUE FORM)))
(SETQ VAL
(EVAL (DSKGET (CADR VAL) (CADDR VAL) 'VALUE NIL)))))
(WHEN (AND $REFCHECK (MEMQ FORM (CDR $VALUES))
(NOT (MEMQ FORM REFCHKL)))
(SETQ REFCHKL (CONS FORM REFCHKL))
(MTELL "~:M has value.~%" FORM))
(RETURN VAL)))
((OR (AND (ATOM (CAR FORM))
(SETQ FORM (CONS (NCONS (CAR FORM)) (CDR FORM))))
(ATOM (CAAR FORM)))
(LET ((BAKTRCL BAKTRCL) TRANSP)
(PROG (U ARYP)
(declare (special aryp))
;;(COND ((EQ DEBUG '$ALL) (SETQ BAKTRCL (CONS FORM BAKTRCL))))
(setq *last-meval1-form* form)
(SETQ ARYP (MEMQ 'array (CDAR FORM)))
(COND ((AND (NOT OPEXPRP) (NOT ARYP)
(MEMQ (CAAR FORM) '(MPLUS MTIMES MEXPT MNCTIMES)))
(GO C))
;; dont bother pushing mplus and friends on baktrcl
;; should maybe even go below aryp.
((AND debug
(PROGN
;(SETQ BAKTRCL (CONS FORM BAKTRCL))
;; if wanting to step, the *break-points*
;; variable will be set to a vector (possibly empty).
(when (and *break-points*
(or (null *break-step*)
(null (funcall *break-step* form))))
(let ((ar *break-points*))
(declare (type (vector t) ar))
(sloop for i below (fill-pointer ar)
when (eq (car (aref ar i)) form)
do (*break-points* form)
(loop-finish))))
NIL)))
((AND $SUBSCRMAP ARYP
(DO ((X (MARGS FORM) (CDR X)))
((OR (NULL X) (MXORLISTP (CAR X))) X)))
(SETQ NOEVALARGS NIL) (RETURN (SUBGEN FORM)))
((EQ (CAAR FORM) 'MQAPPLY) (RETURN (MQAPPLY1 FORM))))
(BADFUNCHK (CAAR FORM) (CAAR FORM) NIL)
A (SETQ U (OR (SAFE-GETL (CAAR FORM) '(NOUN))
(AND NOUNSFLAG (EQ (GETCHAR (CAAR FORM) 1) '%)
(NOT (OR (GETL-FUN (CAAR FORM)
'(SUBR FSUBR LSUBR))
(SAFE-GETL (CAAR FORM)
'(MFEXPR* MFEXPR*S))))
(PROG2 ($VERBIFY (CAAR FORM))
(SAFE-GETL (CAAR FORM) '(NOUN))))
(AND (NOT ARYP) $TRANSRUN
(SETQ TRANSP
(OR (SAFE-MGETL (CAAR FORM) '(T-MFEXPR))
(SAFE-GETL (CAAR FORM)
'(TRANSLATED-MMACRO)))))
(AND (NOT ARYP)
(SETQ U
(OR (SAFE-MGET (CAAR FORM) 'TRACE)
(AND $TRANSRUN
(SAFE-GET (CAAR FORM) 'TRANSLATED)
(NOT (SAFE-MGET (CAAR FORM)
'LOCAL-FUN))
(SETQ TRANSP T) (CAAR FORM))))
(GETL-FUN U '(EXPR SUBR LSUBR)))
(COND (ARYP (SAFE-MGETL (CAAR FORM) '(HASHAR ARRAY)))
((SAFE-MGETL (CAAR FORM) '(MEXPR MMACRO)))
((SAFE-MGETL (CAAR FORM) '(T-MFEXPR)))
(T (OR (SAFE-GETL (CAAR FORM)
'(MFEXPR* MFEXPR*S))
(GETL-FUN (CAAR FORM)
'(SUBR FSUBR EXPR FEXPR macro
LSUBR)))))))
(COND ((NULL U) (GO B))
((AND (MEMQ (CAR U) '(MEXPR MMACRO)) (MFILEP (CADR U)))
(SETQ U (LIST (CAR U)
(DSKGET (CADADR U) (CAR (CDDADR U))
(CAR U) NIL))))
((AND (MEMQ (CAR U) '(ARRAY HASHAR)) (MFILEP (CADR U)))
(I-$UNSTORE (NCONS (CAAR FORM)))
(RETURN (MEVAL1 FORM))))
(RETURN
(COND ((EQ (CAR U) 'HASHAR)
(HARRFIND (CONS (CAR FORM) (MEVALARGS (CDR FORM)))))
((MEMQ (CAR U) '(FEXPR FSUBR))
(IF FEXPRERRP
(MERROR "Attempt to call ~A ~A from MACSYMA level.~
~%Send a bug note."
(CAR U) (CAAR FORM)))
(SETQ NOEVALARGS NIL) (APPLY (CAAR FORM) (CDR FORM)))
((OR (AND (EQ (CAR U) 'SUBR)
(PROG2 (MARGCHK (CAAR FORM) (CDR FORM)) T))
(EQ (CAR U) 'LSUBR))
; ((MEMQ (CAR U) '(SUBR LSUBR))
; (MARGCHK (CAAR FORM) (CDR FORM)))
(APPLY (CAAR FORM) (MEVALARGS (CDR FORM))))

((EQ (CAR U) 'NOUN)
; (MARGCHK (CAAR FORM) (CDR FORM))
(COND ((OR (MEMQ (CAAR FORM) NOUNL) NOUNSFLAG)
(SETQ FORM (CONS (CONS (CADR U) (CDAR FORM))
(CDR FORM)))
(GO A))
(ARYP (GO B))
((MEMQ (CAAR FORM) '(%SUM %PRODUCT))
(SETQ U (DO%SUM (CDR FORM) (CAAR FORM))
NOEVALARGS NIL)
(CONS (NCONS (CAAR FORM)) U))
(T (MEVAL2 (MEVALARGS (CDR FORM)) FORM))))
((EQ (CAR U) 'array)
(ARRFIND (CONS (CAR FORM) (MEVALARGS (CDR FORM)))))
((EQ (CAR U) 'MEXPR)
(MLAMBDA (CADR U) (CDR FORM) (CAAR FORM) NOEVALARGS form))
((MEMQ (CAR U) '(MMACRO TRANSLATED-MMACRO))
(SETQ NOEVALARGS NIL)
(MEVAL (MMACRO-APPLY (CADR U) FORM)))
((EQ (CAR U) 'MFEXPR*)
(SETQ NOEVALARGS NIL) (APPLY (CADR U) (NCONS FORM)))
#+cl
((eq (car u) 'macro)
(setq noevalargs nil)
(setq form (cons(caar form) (cdr form)))
; (setf (car form) (caar form) )
(eval form)
)
#+Maclisp
((EQ (CAR U) 'MFEXPR*S)
(SETQ NOEVALARGS NIL)
;; use macsyma Trace if you want to trace this call.
(SUBRCALL T (CADR U) FORM))
((EQ (CAR U) 'T-MFEXPR) (APPLY (CADR U) (CDR FORM)))
(T (MARGCHK (CAAR FORM) (CDR FORM))
(APPLY (CADR U) (MEVALARGS (CDR FORM))))))
B #+(OR PDP10 Multics Franz NIL cl)
(IF (AND (NOT ARYP) (LOAD-FUNCTION (CAAR FORM) T)) (GO A))
(BADFUNCHK (CAAR FORM) (CAAR FORM) NIL)
(IF (SYMBOLP (CAAR FORM))
(SETQ U (BOUNDP (CAAR FORM)))
(RETURN (MEVAL1-EXTEND FORM)))
C (COND ((OR (NULL U)
(AND (SAFE-GET (CAAR FORM) 'OPERATORS) (NOT ARYP))
(EQ (CAAR FORM) (SETQ U (SYMBOL-VALUE (CAAR FORM)))))
(SETQ FORM (MEVAL2 (MEVALARGS (CDR FORM)) FORM))
(RETURN (OR (AND (SAFE-MGET (CAAR FORM) 'ATVALUES)
(AT1 FORM)) FORM)))
((AND ARYP (SAFE-GET (CAAR FORM) 'NONARRAY))
(RETURN (CONS (CONS (CAAR FORM) ARYP)
(MEVALARGS (CDR FORM)))))
((ATOM U)
(BADFUNCHK (CAAR FORM) U NIL)
(SETQ FORM (CONS (CONS (GETOPR U) ARYP) (CDR FORM)))
(GO A))
((EQ (CAAR U) 'LAMBDA)
(IF ARYP
(MERROR "Improper array call")
(RETURN (MLAMBDA U (CDR FORM)
(CAAR FORM) NOEVALARGS form))))
(T (RETURN (MAPPLY1 U (MEVALARGS (CDR FORM))
(CAAR FORM) form)))))))
(T (MAPPLY1 (CAAR FORM) (MEVALARGS (CDR FORM)) (CAAR FORM) form))))
.