home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / LISP / PDLISP.ZIP / LED.L < prev    next >
Encoding:
Text File  |  1986-02-13  |  21.1 KB  |  714 lines
  1. ; LED.L - UNXLISP structure editor
  2. ;
  3. ; Copyright (c) 1985 by David Morein
  4. ; You can do anything you like with this file,
  5. ; as long as you aren't trying to put me out of
  6. ; business.
  7. ;
  8. ; Similar to, but rather simple-minded by comparison with,
  9. ; the BBN Interlisp editor.
  10. ;
  11. ; note - edit this file with tabs set to 4
  12. ;
  13. ; summary of LED commands:
  14. ;
  15. ; n, where n is an integer:
  16. ;
  17. ;   n > 0 ==> make the current expression
  18. ;   the nth element of the current expression
  19. ;
  20. ;   n < 0 ==> make the current expression
  21. ;   the nth from the last element of the 
  22. ;   current expression. (i.e., -1 selects
  23. ;   the last element, -2 the second from
  24. ;   the last, etc.)
  25. ;
  26. ;   n = 0 => pops the thread one level.
  27. ;
  28. ; ^ pops the thread all the way back to the top.
  29. ; OK ends the edit and accepts the altered expression.
  30. ; Q ends the edit with no changes.
  31. ; E evaluates an expression and prints its value.
  32. ; P prints the current expression.
  33. ; PP pretty-prints the current expression
  34. ; COPY copies the entire thread to a safe place.
  35. ; RESTORE restores the thread to the value which
  36. ;   was saved by copy.
  37. ; MARK sets a mark in the mark list
  38. ; < goes back 1 place in the mark list, but does not pop the mark list.
  39. ; << goes back 1 place in the mark list, and pops the mark list.
  40. ; POFF turns off the print flag.
  41. ; PON turns on the print flag.
  42. ;
  43. ; find command:
  44. ; (f e) searches for the expression e in the current expression.
  45. ; if found, the found expression becomes the new current expression.
  46. ;
  47. ; structure modification commands:
  48. ;
  49. ; (n e), n>1 replaces the nth element of the current expression with e
  50. ; (n e1 e2 ... em), n,m > 1 replaces the nth element of the
  51. ;   current expression with e1 e2 ... em.
  52. ; (-n e), n > 1 inserts e before the nth element of the current expression.
  53. ; (-n e1 e2 ... em), n,m > 1 inserts e1 ... em before the nth element
  54. ;   of the current expression.
  55. ; (r x y) "Replace" - replaces all occurrences of x in the
  56. ;          current expression by y. The replacement is done
  57. ;          throughout the current expression, and not just
  58. ;          at the top-most level. For example, if the current
  59. ;          expression were (LAMBDA (X Y) (+ X Y)), then
  60. ;          typing (r y z) would change the current expression
  61. ;          to (LAMBDA (X Z) (+ X Z)).
  62. ;
  63. ; parenthesis moving commands:
  64. ; (bi m n)  "Both In" - inserts parenthesis before the mth element and
  65. ;            after the nth element of the current expression.
  66. ;            For example, if the current expression were (a b c d e),
  67. ;            then executing (bi 3 4) would change it to (a b (c d) e).
  68. ;
  69. ; (bo n)    "Both Out" - removes both parenthesis from the nth
  70. ;            element of the current expression, and splices
  71. ;            its elements into the current expression. 
  72. ;            For example, if the current expression were
  73. ;            (a b (c d) e f), then executing (bo 3) would
  74. ;            result in (a b c d e f).
  75. ;
  76. ; (li n)    "Left In" - inserts a left parenthesis before the
  77. ;            nth element, and a matching right parenthesis
  78. ;            at the end of the current expression. For example,
  79. ;            if (a b c d e) were the current expression, then
  80. ;            executing (li 2) would result in (a (b c d e)).
  81. ;
  82. ; (lo n)    "Left Out" - removes a left parenthesis from the
  83. ;            nth element of the current expression, and
  84. ;            deletes all elements after the nth element.
  85. ;            For example, if the current expression were
  86. ;            (a b (c d) e f), then executing (lo 3) would
  87. ;            result in (a b c d).
  88. ;
  89. ; (ri m n)  "Right In" - moves the right paren at the end of
  90. ;            the mth element inward until it is after the nth
  91. ;            element of the mth element of the current expression.
  92. ;            The remainder of the mth element is elevated to
  93. ;            the top-most level of the current expression.
  94. ;            For example, if the current expression were
  95. ;            (a b (c d e) f g), then executing (ri 3 2) would
  96. ;            change it to (a b (c d) e f g).
  97. ;
  98. ; (ro n)    "Right Out" - moves the right parenthesis at
  99. ;            the end of the nth element out to the end of
  100. ;            the current expression. The rest of the elements
  101. ;            following the nth are moved inside of the
  102. ;            nth element. For example, if the current expression
  103. ;            were (a b (c d) e f) then executing (ro 3)
  104. ;            would change it to (a b (c d e f)).
  105. ;
  106. ; note - all of the above parenthesis moving commands take
  107. ;        negative arguments, which are processed in the same
  108. ;        way as simple numerical commands. That is, -1
  109. ;        refers to the last element of the current expression,
  110. ;        -2 to the second to the last element, and so on.
  111. ;
  112. ;
  113. (pdq /sys/cmd)              ;start at /sys/cmd.
  114. (mcdq led)                  ;make /sys/cmd/led
  115. (add-to-path '/sys/cmd/led)    ;put editor on reader-search-path.
  116. ;
  117. ; global symbols:
  118. ;
  119. ; global functions:
  120. (global 'ledfq 'ledeq 'ledpq 'ledvq)
  121. ;               
  122. ; editor commands:
  123. (global
  124. 'ok
  125. 'q
  126. 'e
  127. 'p
  128. 'pp
  129. 'mark
  130. '^
  131. '<<
  132. 'poff
  133. 'pon
  134. 'r
  135. 'i
  136. 'n
  137. 'p
  138. 'f
  139. 'ednth
  140. 'ri
  141. 'ro
  142. 'li
  143. 'lo
  144. 'bi
  145. 'bo
  146. 'm
  147. 'd)
  148. ;
  149. ; 
  150. ; explanation of variables global to this file:
  151. ;   thread - list of expressions being edited.
  152. ;            (car thread) is the current expression.
  153. ;
  154. (setq printflag t)
  155. ; print on by default
  156. ;
  157. (setq printlevel 3)
  158. (setq maxlevel 100)
  159. ;
  160. ; ledeq - edits an arbitrary s-expression
  161. ;
  162. (def ledeq (nlambda (x)
  163.     (progn  (setq thread nil)
  164.             (setq m nil)
  165.             (lede1 x))))
  166. ;
  167. ;
  168. ; ledfq - edits the function definition cell of a symbol.
  169. ;
  170. (def ledfq (nlambda (fn)
  171.     (prog   ()
  172.             (pushpath '/sys/cmd/led)    ;put editor on reader-search-path.
  173.             (setq thread nil)           ;initialize the thread
  174. ;
  175. ; filter out symbols which do not have an editable fn def
  176. ;
  177.             (cond
  178.             ((or (null (getd fn)) (compiled-function-p fn))
  179.                     (return '(not editable))))
  180. ;
  181. ; edit the fn def
  182. ;
  183.             (putd fn (lede1 (getd fn)))
  184. ;
  185. ; pop editor off search-path
  186. ;
  187.             (poppath)
  188.             (return fn))))
  189. ;
  190. ; ledvq - edits the variable binding of a symbol
  191. ;
  192. (def ledvq (nlambda (someatom)
  193.     (progn
  194.             (setq thread nil)
  195.             (cond ((not (boundp someatom))
  196.                    (err "***> LEDV: symbol not bound as a variable.")))
  197.             (set someatom (lede1 (eval someatom)))
  198.             someatom)))
  199. ;
  200. ;
  201. ; ledpq - edits the property list of an atom.
  202. ;
  203. (def ledpq (nlambda (someatom)
  204.     (progn
  205.             (setq thread nil)
  206.             (setplist someatom (lede1 (symbol-plist someatom)))
  207.             someatom)))
  208. ;
  209. ; lede1 - edits an arbitrary s-expression
  210. ;   x   - expression to be edited
  211. ;   
  212. ; if the user accepts the changes via the OK command,
  213. ; then this function returns the edited expression;
  214. ; otherwise, it returns the original expression.
  215. ;
  216. (defun lede1 (x)
  217.     (prog   (c copied)                      ;prog variables
  218.             (setq old_value (copy-tree x))  ;save old value of x
  219. ;
  220. ; start the thread, if necessary
  221. ;
  222.             (cond ((null thread) (setq thread (list x))))
  223. ;
  224. ; initialize some variables, output 'LED', and print current expression:
  225. ;
  226.             (princ "LED")
  227.             (setq edok nil)         ;initialize editor accept flag
  228.             (setq edquit nil)       ;initialize editor quit flag
  229. ;
  230. ; enter main editing loop:
  231. ;
  232. editloop
  233. ;
  234. ; if the editor accept flag is set, then return the altered expression:
  235. ;
  236.             (cond (edok (return (car (last thread)))))
  237. ;
  238. ; if the editor quit flag is set, then return the original value:
  239. ;
  240.             (cond (edquit (return old_value)))
  241. ;
  242. ; if the printflag is set, then print the current expression:
  243. ;
  244.             (cond (printflag (terpri) (editcom 'p)))
  245. ;
  246. ; display the editor's prompt:
  247. ;
  248. outprompt
  249.             (terpri)
  250.             (princ '*)
  251. ;
  252. ; read a command:
  253. ;
  254.             (cond ((null (errset (setq c (read)))) (go editloop)))
  255. ;
  256. ; process the command:
  257. ;
  258. ; if the command was p or pp, output the current expression and loop back:
  259. ;
  260.             (cond   ((eq c 'p) (editcom 'p) (go outprompt))
  261.                     ((eq c 'pp) (editcom 'pp) (go outprompt)))
  262. ;
  263. ; otherwise, process the command normally:
  264. ;
  265.             (cond ((errset (editcom c)) t)
  266.                    (t (qmark c)))
  267.             (go editloop)))
  268. ;
  269. ; qmark - outputs a suspect command followed by a question mark.
  270. ;
  271. (def qmark (lambda (c)
  272.     (progn
  273.         (terpri)
  274.         (print c)
  275.         (princ '?)
  276.         (terpri))))
  277. ;
  278. ;
  279. ; editcom - processes an editor command.
  280. ;
  281. (defun editcom (c)
  282.     (progn
  283.             (cond
  284. ;
  285. ; integer - changes the current expression to be the nth
  286. ;           element of the current expression.
  287. ;
  288. ; this call to numberp should be replaced by integerp
  289. ;
  290.                 ((numberp c) (simpnum c) t)
  291. ;
  292. ; if c is atomic, then process an atomic command:
  293. ;
  294.                 ((atom c) (atomcom c) t)
  295. ;
  296. ; otherwise, process a list command:
  297. ;
  298.                 (t (listcom c) t))))
  299. ;
  300. ; atomcom - processes an atomic editor command
  301. ;
  302. (def atomcom (lambda (c)
  303.      (cond
  304. ;
  305. ; ok - sets the variable edok to t.
  306. ;
  307.             ((eq c 'ok)
  308.              (setq edok t))
  309. ;
  310. ; q - quits the edit with no changes
  311. ;
  312.             ((eq c 'q)
  313.              (setq edquit t))
  314. ;
  315. ; e - evaluates an expression & prints its value.
  316. ;
  317.             ((eq c 'e)
  318.              (errset (print (eval (read))))
  319.              (terpri))
  320. ;
  321. ; p - prints the current expression.
  322. ;
  323.             ((eq c 'p)
  324.              (eprint (car thread)))
  325. ;
  326. ; pp - pretty-prints the current expression.
  327. ;
  328.             ((eq c 'pp)
  329.              (terpri)
  330.              (errset (pp (car thread)))
  331.              (terpri))
  332. ;
  333. ; mark - sets a mark
  334. ;
  335.             ((eq c 'mark)
  336.              (setq m (cons thread m)))
  337. ;
  338. ; ^ - pop the thread back to the top
  339. ;
  340.             ((eq c '^)
  341. ;            (setq thread (list (last thread))))
  342.              (setq thread (last thread)));
  343. ;
  344. ; copy - copies current expression to a safe place
  345. ;
  346.             ((eq c 'copy)
  347.              (setq copied (copy-tree thread)))
  348. ;
  349. ; restore - restores current expression to value
  350. ;           which was saved by copy.
  351. ;
  352.             ((eq c 'restore)
  353.              (setq thread copied))
  354. ;
  355. ; < - goes back 1 place in the mark list
  356. ;
  357.             ((eq c '<)
  358.              (cond  (m (setq thread (car m)))
  359.                     (t (err "***> LED: no marks"))))
  360. ;
  361. ; << - same as < except pops the mark list
  362. ;
  363.             ((eq c '<<)
  364.              (cond  (m (setq thread (car m))
  365.                        (setq m (cdr m)))
  366.                     (t (err "***> LED: no marks"))))
  367. ;
  368. ; poff - turn off the print flag:
  369. ;
  370.             ((eq c 'poff)
  371.              (setq printflag nil))
  372. ;
  373. ; pon - turn on the print flag:
  374. ;
  375.             ((eq c 'pon)
  376.              (setq printflag t))
  377. ;
  378. ; otherwise, indicate that we couldn't parse the command:
  379. ;
  380.             (t (err nil)))))
  381. ;
  382. ; listcom - this function processes a list command if it can,
  383. ;           otherwise signals an error with ERR.
  384. ;
  385. (def listcom (lambda (c)
  386.     (prog   (c1 c2 c3)
  387.             (setq ce (car thread))          ; ce := current expression
  388.             (setq c1 (car c))               ; c1 := 1st element of command list
  389.             (setq c2 (cadr c))              ; c2 := 2nd element of command list
  390.             (setq c3 (caddr c))             ; c3 := 3rd element of command list
  391. ;
  392. ; dispatch on c1, the 1st element of the command list:
  393. ;
  394.             (return
  395.             (cond   
  396.                 ((numberp c1)
  397.                  (compnum c))               ;complex # command
  398.  
  399.         ((eq c1 'd)                 ;delete command
  400.          (leddelete c2))
  401.  
  402.         ((eq c1 'i)                 ;insert command
  403.          (ledinsert c2 c3))
  404.  
  405.                 ((eq c1 'r)                 ;replace command
  406.                  (dsubst c2 c3 ce))
  407.  
  408.                 ((eq c1 'f)                 ;find command
  409.                  (ledfind c2))
  410.  
  411.                 ((eq c1 'nth)   
  412.                  (setq thread (cons (lednthcdr c3 c2) thread)))
  413.  
  414.                 ((member c1 '(ri ro li lo bi bo))           ;paren move command
  415.                  (apply1 c1 (append (cdr c) (list ce))))
  416. ;
  417. ; failure to parse command.
  418. ;
  419.                 (t (err nil)))))))
  420. ;
  421. ; printlevel - swaps the current printlevel with x
  422. ;
  423. (def printlevel (lambda (x)
  424.     (prog   (a)
  425.             (setq a printlevel)
  426.             (setq printlevel x)
  427.             (return a))))
  428. ;
  429. ; simpnum - processes simple numeric commands
  430. ;   n = 0 ==> go up 1 level in the thread
  431. ;   n > 0 ==> go to the nth element of current expression
  432. ;             (expression # 1 is the left-most expression)
  433. ;   n < 0 ==> go to the nth from the last element of the
  434. ;             current expression
  435. ;
  436. (def simpnum (lambda (n)
  437.     (cond   
  438. ;
  439. ; n = 0 => up 1 level in thread
  440. ;
  441.             ((equal n 0)
  442.         (cond
  443.             ((null (cdr thread))
  444.                 (err "***> LED: already at top of thread"))
  445.             (t (setq thread (cdr thread)))))
  446. ;
  447. ; n > 0 => go to nth element of current expression
  448. ;
  449.             ((> n 0)
  450.                  (cond ((> n (length (car thread)))
  451.                          (err "***> LED: numeric arg larger than list size"))
  452.                         (t (setq thread
  453.                                 (cons
  454.                                     (nth (sub1 n) (car thread))
  455.                                     thread)))))
  456. ;
  457. ; check for negative number too big:
  458. ;
  459.             ((> (* n -1) (length (car thread)))
  460.                 (err "***> LED: numeric arg larger than list size"))
  461. ;
  462. ; n < 0 => go to nth element from end of current expr
  463. ;
  464.             (t (setq thread
  465.                     (cons
  466.                         (nth
  467.                             (+ (length (car thread)) n)
  468.                             (car thread))
  469.                         thread))))))
  470. ;
  471. ; compnum - processes a numeric list command
  472. ;
  473. (def compnum (lambda (c)
  474.     (cond   ((> (car c) 0)
  475.                  (cond  ((> (car c) (length (car thread)))
  476.                          (err nil))
  477.                         (t  (rplaca
  478.                                 thread
  479.                                 (linkbend
  480.                                     (sub1 (car c))
  481.                                     (car thread)
  482.                                     (cdr c)
  483.                                     nil)))))
  484.             ((or    (equal (car c) 0)
  485.                     (null (cdr c))
  486.                     (> (* -1 (car c)) (length (car thread))))
  487.              (err nil))
  488.             (t (rplaca
  489.                     thread
  490.                     (linkbend
  491.                         (sub1 (* -1 (car c)))
  492.                         (car thread)
  493.                         (cdr c)
  494.                         t))))))
  495. ;
  496. ; linkbend - handy dandy link bending routine.
  497. ;            Handles the dirty work for (# ...) commands.
  498. ;
  499. (def linkbend (lambda (n x r d)
  500.     (prog ()
  501.         (cond   ((not (equal n 0))
  502.                  (rplacd (nthcdr (sub1 n) x)
  503.                          (nconc r
  504.                                 (cond   (d (nthcdr n x))
  505.                                         (t (nthcdr (add1 n) x))))))
  506.                 (d  (attach (car r) x)
  507.                     (rplacd x (nconc (cdr r) (cdr x))))
  508.                 (r  (rplaca x (car r))
  509.                     (rplacd x (nconc (cdr r) (cdr x))))
  510.                 (t  (print (list 'aha x))       ;from BBN editor.
  511.                     (rplaca x (cadr x))
  512.                     (rplacd x (cddr x))))
  513.             (return x))))
  514. ;
  515. ;
  516. ; attach - auxilliary function for linkbend
  517. ;
  518. (def attach (lambda (x y)
  519.     (prog   (a)
  520.             (setq a (cons (car y) (cdr y)))
  521.             (rplaca y x)
  522.             (rplacd y a)
  523.             (return y))) )
  524. ;
  525. ;
  526. ; ledmatch - pattern match routine for LED
  527. ;            returns T iff x matches y
  528. ;
  529. ; notes:
  530. ; (1) if the second element of x is eq to '-, then
  531. ;     T is returned if x and y are both lists and the first
  532. ;     element of each matches.
  533. ; (2) if x is eq to '&, then it matches anything.
  534. ;
  535. (def ledmatch (lambda (x y srchlevel)
  536.     (cond   ((eql maxlevel srchlevel)
  537.                 (err "***> LED: max search level exceeded."))
  538.             ((equal x y) t)
  539.             ((atom x) (eq x '&))
  540.             ((atom y) nil)
  541.             ((ledmatch (car x) (car y) (+ srchlevel 1))
  542.              (or    (eq (cadr x) '-)
  543.                     (ledmatch (cdr x) (cdr y) (+ srchlevel 1)))))))
  544. ;
  545. ; lednthcdr - special nthcdr function which takes negative arguments:
  546. ;
  547. (def lednthcdr (lambda (n x)
  548.     (cond
  549.         ((< n 0)
  550.             (cond   ((> (* n -1) (length x))
  551.                         (err "***> LED: numeric arg larger than list size."))
  552.                     (t (nthcdr (+ n (length x)) x))))
  553.         ((> n 0)
  554.             (cond   ((> n (length x))
  555.                         (err "***> LED: numeric arg larger than list size."))
  556.                     (t (nthcdr (sub1 n) x))))
  557.         ((equal n 0)
  558.             (err "***> LED: invalid arg.")))))
  559. ;
  560. ;                                               
  561. ; ro - "right out" command, moves right parenthesis out.
  562. ;
  563. (def ro (lambda (n x)
  564.     (prog   (a)
  565.             (setq a (lednthcdr n x))
  566.             (cond ((or (null a) (atom (car a))) (err nil)))
  567.             (rplacd (last (car a)) (cdr a))
  568.             (rplacd a nil))) )
  569. ;
  570. ;
  571. ; ri - "right in" command, moves right parenthesis in.
  572. ;
  573. (def ri (lambda (m n x)
  574.     (prog   (a b)
  575.             (setq a (lednthcdr m x))
  576.             (setq b (lednthcdr n (car a)))
  577.             (cond ((or (null a) (null b)) (err nil)))
  578.             (rplacd a (nconc (cdr b) (cdr a)))
  579.             (rplacd b nil))) )
  580. ;
  581. ;
  582. ; li - "left in" command, moves left parenthesis in.
  583. ;
  584. (def li (lambda (n x)
  585.     (prog   (a)
  586.             (setq a (lednthcdr n x))
  587.             (cond ((null a) (err nil)))
  588.             (rplaca a (cons (car a) (cdr a)))
  589.             (rplacd a nil))) )
  590. ;
  591. ;
  592. ; lo - "left out" command, moves left parenthesis out.
  593. ;
  594. (def lo (lambda (n x)
  595.     (prog   (a)
  596.             (setq a (lednthcdr n x))
  597.             (cond ((or (null a) (atom (car a))) (err nil)))
  598.             (rplacd a (cdar a))
  599.             (rplaca a (caar a))) ))
  600. ;
  601. ;
  602. ; bi - "both in" command, moves both parenthesis in.
  603. ;
  604. (def bi (lambda (m n x)
  605.     (prog   (a b)
  606.             (setq b (cdr (setq a (lednthcdr n x))) )
  607.             (setq x (lednthcdr m x))
  608.             (cond ((and a (null (> (length x))) )
  609.                    (rplacd a nil)
  610.                    (rplaca x (cons (car x) (cdr x)))
  611.                    (rplacd x b))
  612.                   (t  (err nil))) )))
  613. ;
  614. ;
  615. ; bo - "both out" command, moves both parenthesis out.
  616. ;
  617. (def bo (lambda (n x)
  618.     (progn
  619.         (setq x (lednthcdr n x))
  620.         (cond ((atom (car x)) (err nil)))
  621.         (rplacd x (nconc (cdar x) (cdr x)))
  622.         (return (rplaca x (caar x))) )))
  623. ;
  624. ;
  625. ; dsubst - destructive substitution function;
  626. ;   x - oldval
  627. ;   y - newval
  628. ;   z - s-expression being altered.
  629. ;
  630. ; Substitutes y for x in z.
  631. ; Uses rplaca and permanently alters z.
  632. ;
  633. (def dsubst (lambda (x y z)
  634.     (progn
  635.     (cond
  636.         ((consp z)
  637.             (progn
  638.                 (cond
  639.                     ((equal x (car z))  (rplaca z y))
  640.                     (t                  (dsubst x y (car z))) )
  641.                 (cond ((cdr z)  (dsubst x y (cdr z))) )))
  642.         (t z))  ;if z is not a cons, do nothing.
  643.     z)))
  644. ;
  645. ;
  646. ; eprint - "safe" editor print function
  647. ; prints x to a maximum depth of printlevel.
  648. ; 
  649. (defun eprint (x) (print (sprint x printlevel)))
  650. ;
  651. (defun apply1 (f l)
  652.     (eval (cons f (mapcar '(lambda (z) (list 'quote z)) l))))
  653. ;
  654. ;
  655. ; leddelete - deletes element N from the current expression
  656. ;
  657. (def leddelete (lambda (n)
  658.     (prog   (a)
  659.         (if (equal n 1)
  660.         (progn
  661.             (setq ce (cdr ce))
  662.             (rplaca thread ce))
  663.         (progn
  664.             (rplacd
  665.                 (lednthcdr (- n 1) ce)
  666.                 (lednthcdr (+ n 1) ce)))))))
  667. ;
  668. ;
  669. ; ledinsert - inserts X before position N in CE
  670. ;
  671. (def ledinsert (lambda (n x)
  672.     (prog   (a b)
  673.         (if (equal n 1)
  674.         (progn
  675.             (setq ce (cons x ce))
  676.             (rplaca thread ce))
  677.         (progn
  678.             (setq a (lednthcdr n ce))
  679.             (setq b (lednthcdr (sub1 n) ce))
  680.             (rplacd b (cons x a))
  681.             (rplaca thread ce)
  682.             (return ce))))))
  683. ;
  684. ;
  685. ; ledfind - general purpose find routine.
  686. ;           finds expression S in THREAD.
  687. ;           The search proceeds downwards
  688. ;           from the current expression,
  689. ;           left recursively.
  690. ;
  691. (def ledfind (lambda (target)
  692.     (cond
  693.         ((setq result (ledfind1 target (car thread) 1))
  694.             (setq thread (cons result thread)))
  695.         (t  (princ "***> FIND: could not find target in current exp")))))
  696. ;       
  697. ;           
  698. ;
  699. ; ledfind1 - finds first match of X in Y.
  700. ; srchlevel is the current search level,
  701. ; and is not permitted to exceed maxlevel.
  702. ;
  703. (def ledfind1 (lambda (x y srchlevel &aux result)
  704.     (cond   ((eql srchlevel maxlevel)
  705.                 (err "***> LED: max search level exceeded in LEDFIND"))
  706.             ((ledmatch x y srchlevel) y)
  707.             ((atom y) nil)
  708.             ((setq result (ledfind1 x (car y) (+ srchlevel 1))) result)
  709.             ((setq result (ledfind1 x (cdr y) (+ srchlevel 1))) result)
  710.             (t nil))))
  711. ;
  712. (popd)      ;return to entry directory
  713.  
  714.