835 lines
27 KiB
Common Lisp
835 lines
27 KiB
Common Lisp
|
||
; -*- Mode: Lisp -*- Filename: edit.s
|
||
|
||
; Last Revision: 13-Sep-85 1230ct
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; TI SCHEME -- PCS Compiler ;
|
||
; Copyright 1985 (c) Texas Instruments ;
|
||
; ;
|
||
; Paul Kristoff ;
|
||
; ;
|
||
; The Scheme Structure Editor ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
|
||
(define edit
|
||
(letrec ((read-eval-print-loop
|
||
(letrec ((read-command
|
||
(lambda ()
|
||
(print 'EDIT->)
|
||
(set! buffer (read))
|
||
(if (atom? buffer)
|
||
(set! buffer (list (list buffer)))
|
||
(if (atom? (car buffer))
|
||
(set! buffer (list buffer))))))
|
||
(do-command
|
||
(lambda ()
|
||
(if (or (number? (car command))
|
||
(eq? (car command) '*))
|
||
(move (car command))
|
||
(case (car command)
|
||
((?) (print
|
||
(print-depth-length fp 2 10)))
|
||
((P) (print fp))
|
||
((??) (pp
|
||
(print-depth-length fp 2 10)))
|
||
((PP) (pp fp))
|
||
((N) (next))
|
||
((PR) (previous))
|
||
((B) (beginning))
|
||
((T) (top))
|
||
((F) (find (cadr command)))
|
||
((IB) (insert-before
|
||
(cadr command)
|
||
(caddr command)))
|
||
((IA) (insert-after
|
||
(cadr command)
|
||
(caddr command)))
|
||
((SB) (splice-before
|
||
(cadr command)
|
||
(caddr command)))
|
||
((SA) (splice-after
|
||
(cadr command)
|
||
(caddr command)))
|
||
((D) (delete (cadr command)))
|
||
((DP) (delete-parentheses
|
||
(cadr command)))
|
||
((AP) (add-parentheses
|
||
(cadr command)
|
||
(caddr command)))
|
||
((S) (substitute
|
||
(cadr command)
|
||
(caddr command)))
|
||
((R) (replace
|
||
(cadr command)
|
||
(caddr command)))
|
||
((PS) (ps))
|
||
((MAC?) (mac? (cadr command)))
|
||
((MAC) (create-ed-macro
|
||
(cadr command)
|
||
(caddr command)))
|
||
((Q) (set! done? t))
|
||
(else (if (ed-macro? (car command))
|
||
(expand-mac command)
|
||
(begin
|
||
(newline)
|
||
(set! buffer nil)
|
||
(writeln
|
||
" ? Unknown command: "
|
||
command))))
|
||
))))
|
||
(mac?
|
||
(lambda (name)
|
||
(let ((temp (ed-macro? name)))
|
||
(if (null? temp)
|
||
(begin (writeln name " is not a macro.")
|
||
nil)
|
||
(pp (list 'mac (list name (car temp))
|
||
(cdr temp)))))))
|
||
(ed-macro?
|
||
(lambda (name)
|
||
(and (symbol? name)
|
||
(getprop name 'ed*macro))))
|
||
(expand-mac
|
||
(lambda (com)
|
||
(let* ((x (getprop (car com) 'ed*macro))
|
||
(eem (expand-ed-macro
|
||
(cdr com)
|
||
(car x)
|
||
(cdr x))))
|
||
(if (eq? eem 'error)
|
||
(begin (set! buffer nil)
|
||
(writeln " ? Error with macro"
|
||
command))
|
||
(set! buffer
|
||
(append eem buffer))))))
|
||
(create-ed-macro
|
||
(lambda (name&nargs expan)
|
||
(putprop (car name&nargs)
|
||
(cons (cadr name&nargs)
|
||
expan)
|
||
'ed*macro)))
|
||
(expand-ed-macro
|
||
(lambda (args nargs expan)
|
||
(letrec
|
||
((loop
|
||
(lambda (expan)
|
||
(cond ((null? expan) nil)
|
||
((atom? expan)
|
||
(let ((n (arg? expan)))
|
||
(if n
|
||
(list-ref args (-1+ n))
|
||
expan)))
|
||
((atom? (car expan))
|
||
(let ((n (arg? (car expan))))
|
||
(cons (if n
|
||
(list-ref args
|
||
(-1+ n))
|
||
(car expan))
|
||
(loop (cdr expan)))))
|
||
(t (cons (loop (car expan))
|
||
(loop (cdr expan)))))))
|
||
)
|
||
(if (= (length args) nargs)
|
||
(loop expan)
|
||
'error))))
|
||
)
|
||
(lambda ()
|
||
(if (not (memq (car command) '(P ? PP ??)))
|
||
(print (print-depth-length fp 2 10)))
|
||
(if (not done?)
|
||
(begin (read-command)
|
||
(do ()
|
||
((null? buffer))
|
||
(set! command (car buffer))
|
||
(when (atom? command)
|
||
(set! command (list command)))
|
||
(set! buffer (cdr buffer))
|
||
(do-command))
|
||
(read-eval-print-loop))
|
||
(begin (top) fp)))))
|
||
|
||
|
||
|
||
;--------------------------------------------------------------------;
|
||
; MOVE ;
|
||
; Argument: integer or * ;
|
||
; Move repositions the fp to be the nth element of the current ;
|
||
; fp. If an integer is positive the nth element will be from ;
|
||
; the left. If the number is too large then the fp is moved to ;
|
||
; last element from the left. If negative the nth element will ;
|
||
; be from the right. If the absolute value of the number is ;
|
||
; larger than the number of elements in the fp, then the fp is ;
|
||
; repositioned to the 1st element from the left. If the the ;
|
||
; argument is *, the fp is repositioned to be the cdr of the ;
|
||
; cons cell of the fp. ;
|
||
;--------------------------------------------------------------------;
|
||
|
||
(move
|
||
(let ((stop (lambda ()
|
||
(newline)
|
||
(writeln " ? Cannot do a Move on an atom."))))
|
||
(lambda (n)
|
||
(cond ((atom? fp) (stop))
|
||
((eq? n '*)
|
||
(begin (push fp '*)
|
||
(set! fp (cdr (last-pair fp)))
|
||
fp))
|
||
(t (let ((num (correct-position n)))
|
||
(cond ((null? n) (circular num))
|
||
((<= num 0) (push fp 1)
|
||
(set! fp (car fp)))
|
||
(t (let ((smart-list
|
||
(smart-list-ref
|
||
fp (-1+ num))))
|
||
(push fp
|
||
(- num (cdr smart-list)))
|
||
(set! fp (car smart-list))
|
||
fp)))))))))
|
||
|
||
;--------------------------------------------------------------------;
|
||
; BEGINNING ;
|
||
; No arguments ;
|
||
; Repositions the fp to be the parent of the current fp ;
|
||
;--------------------------------------------------------------------;
|
||
(beginning
|
||
(let ((stop (lambda ()
|
||
(newline)
|
||
(writeln " ? Already at top level."))))
|
||
(lambda ()
|
||
(if (at-top-level?)
|
||
(stop)
|
||
(let ((stack-frame (pop)))
|
||
(set! fp (fp-part stack-frame))
|
||
fp)))))
|
||
|
||
;--------------------------------------------------------------------;
|
||
; NEXT ;
|
||
; No Arguments ;
|
||
; Moves the fp to be the next element to the right of the parent ;
|
||
; of the current fp. If the fp is pointing to the last element, ;
|
||
; the fp remains the same. ;
|
||
;--------------------------------------------------------------------;
|
||
|
||
(next
|
||
(let ((stop (lambda ()
|
||
(newline)
|
||
(writeln
|
||
" ? There is no Next from this position")))
|
||
(stop1
|
||
(lambda ()
|
||
(newline)
|
||
(writeln
|
||
" ? Can't execute Next command at top level"))))
|
||
(lambda ()
|
||
(if (at-top-level?)
|
||
(stop1)
|
||
(let ((stack-frame (pop)))
|
||
(set! fp (fp-part stack-frame))
|
||
(move (if (eq? (element-part stack-frame) '*)
|
||
(begin (stop) '*)
|
||
(1+ (element-part stack-frame))))
|
||
fp)))))
|
||
|
||
;--------------------------------------------------------------------;
|
||
; PREVIOUS ;
|
||
; No Arguments ;
|
||
; Repositions the fp to be the previous element of the parent of ;
|
||
; the current fp. If already at the first element of the fp, then ;
|
||
; the fp remains the same. ;
|
||
;--------------------------------------------------------------------;
|
||
(previous
|
||
(let ((stop (lambda ()
|
||
(newline)
|
||
(writeln
|
||
" ? There is no Previous from this position")))
|
||
(stop1 (lambda ()
|
||
(newline)
|
||
(writeln
|
||
" ? Can't execute Previous at top level"))))
|
||
(lambda ()
|
||
(if (at-top-level?)
|
||
(stop1)
|
||
(let ((stack-frame (pop)))
|
||
(set! fp (fp-part stack-frame))
|
||
(move (cond ((eq? (element-part stack-frame) '*)
|
||
(begin (stop) '*))
|
||
((= (element-part stack-frame) 1) (stop) 1)
|
||
(t (-1+ (element-part stack-frame)))))
|
||
fp)))))
|
||
|
||
;--------------------------------------------------------------------;
|
||
; TOP ;
|
||
; No arguments ;
|
||
; Sets the fp to point to the car of very-top. Resets the stack. ;
|
||
;--------------------------------------------------------------------;
|
||
(top
|
||
(lambda ()
|
||
(set! fp (car very-top))
|
||
(set! stack initial-stack)
|
||
))
|
||
;--------------------------------------------------------------------;
|
||
; FIND ;
|
||
; Can take an argument ;
|
||
; Searches beginning with the FP (not including the FP) until the ;
|
||
; it either finds the pfv (using equal?) or the whole stack is ;
|
||
; popped. If it is found the FP is moved to that point. If is ;
|
||
; it is not the FP and STACK remain the same. The value maybe ;
|
||
; inside the FP. ;
|
||
;--------------------------------------------------------------------;
|
||
(find
|
||
(letrec ((find-next
|
||
(lambda ()
|
||
(cond ((equal? fp pfv) (set! found? t))
|
||
((atom? fp) (get-next-element))
|
||
(t (move 1)
|
||
(find-next)))))
|
||
(get-next-element
|
||
(let ((stop (lambda ()
|
||
(newline)
|
||
(writeln " ? Did not find "
|
||
pfv))))
|
||
(lambda ()
|
||
(if (at-top-level?)
|
||
(stop)
|
||
(let ((stack-frame (pop)))
|
||
(let ((tfp (fp-part stack-frame))
|
||
(tel (element-part
|
||
stack-frame)))
|
||
(if (eq? tel '*)
|
||
(get-next-element)
|
||
(let ((next-element
|
||
(list-ref-* tfp tel)))
|
||
(push tfp
|
||
(if (eq? (cdr next-element)
|
||
'*)
|
||
'*
|
||
(1+ tel)))
|
||
(set! fp
|
||
(car next-element))
|
||
(find-next)))
|
||
))))))
|
||
(temp-stack nil)
|
||
(temp-fp nil)
|
||
(found? nil)
|
||
(pfv '**unbound**)
|
||
)
|
||
(lambda v
|
||
(if (not (null? (car v)))
|
||
(set! pfv (car v)))
|
||
(set! found? nil)
|
||
(set! temp-stack stack)
|
||
(set! temp-fp fp)
|
||
(if (atom? fp) ; allows find next if fp is
|
||
(get-next-element) ; equal to the pfv
|
||
(begin (move 1) (find-next)))
|
||
(if (not found?)
|
||
(let ((par (parent stack)))
|
||
(set! stack temp-stack)
|
||
(set! fp temp-fp)))
|
||
fp)))
|
||
;--------------------------------------------------------------------;
|
||
; REPLACE ;
|
||
; arguments n: The element being replaced (nth element of the FP). ;
|
||
; v: The value the nth element will replace. ;
|
||
; Replace will replace the nth element of the FP with v. n can be ;
|
||
; either negative or positive. If too large an error is indicated. ;
|
||
;--------------------------------------------------------------------;
|
||
(replace
|
||
(lambda (n v)
|
||
(cond ((eq? n '*) (set-cdr! (last-pair fp) v))
|
||
((not (number? n))
|
||
(newline)
|
||
(writeln " ? Non-number or non-* to Replace: " n))
|
||
((= n 0) (correct-stack v)
|
||
(set! fp v))
|
||
(t (let ((num (correct-position n)))
|
||
(if (null? num)
|
||
(circular-error n)
|
||
(let ((sc (smart-list-tail
|
||
fp
|
||
(-1+ num))))
|
||
(if (atom? sc)
|
||
(not-enough-elements-error n)
|
||
(set-car! sc v)))))))))
|
||
;--------------------------------------------------------------------;
|
||
; SUBSTITUTE ;
|
||
; arguments for : The value searched for. ;
|
||
; this: The value that replaces the value searched for ;
|
||
; Searches the FP for 'for'. It replaces all occurrences of 'for' ;
|
||
; with 'this'. If none are found it will indicate that. ;
|
||
;--------------------------------------------------------------------;
|
||
(substitute
|
||
(lambda (for this)
|
||
(letrec ((found? nil)
|
||
(subst
|
||
(lambda (l)
|
||
(cond ((null? l) nil)
|
||
((equal? for l) (set! found? t) this)
|
||
((atom? l) l)
|
||
(t (cons (subst (car l))
|
||
(subst (cdr l)))))))
|
||
)
|
||
(set! fp (subst fp))
|
||
(if (not found?)
|
||
(begin (newline)
|
||
(writeln " ? Can't find " for))
|
||
(correct-stack fp))
|
||
fp)))
|
||
(delete
|
||
(lambda (n)
|
||
(cond ((eq? n '*) (set-cdr! (last-pair fp) nil))
|
||
((not (number? n))
|
||
(newline)
|
||
(writeln " ? Non-number or non-* to Delete: " n))
|
||
((zero? n) (set! fp nil) (correct-stack fp))
|
||
(t (let ((num (correct-position n)))
|
||
(cond ((null? num) (circular-error n))
|
||
((atom? fp)
|
||
(newline)
|
||
(writeln
|
||
" ? FP is an atom, can't delete "
|
||
n " element"))
|
||
((= num 1)
|
||
(set! fp (cdr fp))
|
||
(correct-stack fp))
|
||
(t (let ((sc (smart-list-tail fp (- num 2)))
|
||
(scc (smart-list-tail fp num)))
|
||
(if (and (atom? scc)
|
||
(not (null? scc))) ;PRK 53085
|
||
(not-enough-elements-error n)
|
||
(set-cdr! sc scc))))))))))
|
||
;--------------------------------------------------------------------;
|
||
; DELETE PARENTHESES ;
|
||
; argument n: The nth element of the FP ;
|
||
; Deletes the parentheses from around the nth element of the FP. ;
|
||
; The nth element must be a list otherwise an error will occur. n ;
|
||
; maybe either negative or positive. ;
|
||
;--------------------------------------------------------------------;
|
||
(delete-parentheses
|
||
(lambda (n)
|
||
(letrec ((stop1
|
||
(lambda ()
|
||
(newline)
|
||
(writeln
|
||
" ? Can't delete parentheses for this position "
|
||
n)))
|
||
(stop2 (lambda ()
|
||
(newline)
|
||
(writeln " ? Element is not a list")))
|
||
)
|
||
(if (and (number? n) (not (zero? n)))
|
||
(let* ((num (correct-position n)))
|
||
(if (null? num)
|
||
(circular-error n)
|
||
(let ((elem (smart-list-ref fp (-1+ num)))
|
||
(next-elem (smart-list-tail fp num))
|
||
)
|
||
(when (eq? next-elem '*atom-returned*)
|
||
(set! next-elem '()))
|
||
(cond ((atom? fp)
|
||
(newline)
|
||
(writeln
|
||
" ? FP is an atom, can't delete "
|
||
n " element."))
|
||
((not (zero? (cdr elem)))
|
||
(not-enough-elements-error n))
|
||
((not (list? (car elem)))
|
||
(stop2))
|
||
((= num 1)
|
||
(set! fp (append! (car elem) next-elem))
|
||
(correct-stack fp))
|
||
(t (set-cdr! (list-tail fp (- num 2))
|
||
(append! (car elem) next-elem)))))))
|
||
(stop1))
|
||
)))
|
||
;--------------------------------------------------------------------;
|
||
; ADD PARENTHESES ;
|
||
; arguments x: One or two arguments ;
|
||
; Will add parentheses from the first argument to the second ;
|
||
; argument (left to right). The first argument must be to the left ;
|
||
; or the same as the second argument. If the first argument is * or;
|
||
; 0 (zero) the second argument is ignored. ;
|
||
;--------------------------------------------------------------------;
|
||
(add-parentheses
|
||
(lambda x
|
||
(let ((m (car x))(n (cadr x)))
|
||
(cond ((atom? fp)
|
||
(newline)
|
||
(writeln
|
||
" ? FP is an atom, can't Add Parentheses"))
|
||
((eq? m '*)
|
||
(let ((lp (last-pair fp)))
|
||
(set-cdr! lp (list (cdr lp)))))
|
||
((not (number? m))
|
||
(newline)
|
||
(writeln
|
||
" ? Non-number or non-* to Add Parentheses: "
|
||
m))
|
||
((= m 0) (set! fp (cons fp nil))
|
||
(correct-stack fp))
|
||
((eq? n '*)
|
||
(let ((cm (correct-position m)))
|
||
(cond ((null? cm)(circular-error m))
|
||
((= cm 1) (set! fp (cons fp nil))
|
||
(correct-stack fp))
|
||
(t (let ((slt1
|
||
(smart-list-tail fp (- cm 2)))
|
||
(slt2
|
||
(smart-list-tail fp (-1+ cm))))
|
||
(if (atom? slt2)
|
||
(not-enough-elements-error m)
|
||
(set-cdr! slt1
|
||
(cons slt2 nil))))))))
|
||
((not (number? n))
|
||
(newline)
|
||
(writeln
|
||
" ? Non-number or non-* to Add Parentheses: "
|
||
n))
|
||
(t (let ((cm (correct-position m))
|
||
(cn (correct-position n)))
|
||
(cond ((null? cm) (circular-error m))
|
||
((null? cn) (circular-error n))
|
||
((<= cm 0) (not-enough-elements-error m))
|
||
((<= cn 0) (not-enough-elements-error n))
|
||
((> cm cn)
|
||
(newline)
|
||
(writeln
|
||
" ? First argument, " m
|
||
" is positioned to the right of the 2nd, " n))
|
||
(t (let ((end-fp (list-tail fp cn))
|
||
(last-arg-tail
|
||
(smart-list-tail fp (-1+ cn))))
|
||
(if (atom? last-arg-tail)
|
||
(not-enough-elements-error n)
|
||
(begin (set-cdr! last-arg-tail nil)
|
||
(if (= cm 1)
|
||
(begin
|
||
(set! fp
|
||
(cons fp end-fp))
|
||
(correct-stack fp))
|
||
(set-cdr!
|
||
(list-tail fp (- cm 2))
|
||
(cons
|
||
(list-tail fp (-1+ cm))
|
||
end-fp))))))))))
|
||
))))
|
||
;--------------------------------------------------------------------;
|
||
; SPLICE BEFORE ;
|
||
; arguments n: The nth element of the FP ;
|
||
; v: The list of values to be spliced before the nth ;
|
||
; element. ;
|
||
; Splices before the nth element of the FP, the elements in v. If ;
|
||
; v is not a list an error is indicated. ;
|
||
;--------------------------------------------------------------------;
|
||
(splice-before
|
||
(lambda (n v)
|
||
(cond ((atom? fp)
|
||
(newline)
|
||
(writeln
|
||
" ? FP is an atom, can't splice before "
|
||
n " element"))
|
||
((or (not (number? n)) (zero? n))
|
||
(newline)
|
||
(writeln
|
||
" ? First argument must be a non-zero integer: "
|
||
n))
|
||
((not (list? v))
|
||
(newline)
|
||
(writeln " ? Second argument must be a list: " v))
|
||
(t (let ((num (correct-position n)))
|
||
(cond ((null? num)
|
||
(circular-error n))
|
||
((= num 1)
|
||
(set! fp (append! v fp))
|
||
(correct-stack fp))
|
||
(t (let ((slt1
|
||
(smart-list-tail fp (- num 2)))
|
||
(slt2
|
||
(smart-list-tail fp (-1+ num))))
|
||
(if (atom? slt2)
|
||
(not-enough-elements-error n)
|
||
(set-cdr! slt1
|
||
(append! v slt2))))))))
|
||
)))
|
||
;--------------------------------------------------------------------;
|
||
; SPLICE AFTER ;
|
||
; arguments n: The nth element of the FP. ;
|
||
; v: The list of elements that are splice after the nth ;
|
||
; element. ;
|
||
; The elements of v are placed after the nth element of the FP. If ;
|
||
; v is not a list an error is indicated. ;
|
||
;--------------------------------------------------------------------;
|
||
(splice-after
|
||
(lambda (n v)
|
||
(cond ((atom? fp)
|
||
(newline)
|
||
(writeln
|
||
" ? FP is an atom, can't splice after "
|
||
n " element"))
|
||
((or (not (number? n)) (zero? n))
|
||
(newline)
|
||
(writeln
|
||
" ? First argument must be a non-zero integer: "
|
||
n))
|
||
((not (list? v))
|
||
(newline)
|
||
(writeln " ? Second argument must be a list: " v))
|
||
(t (let ((num (correct-position n)))
|
||
(if (null? num)
|
||
(circular-error n)
|
||
(let ((slt1 (smart-list-tail fp (-1+ num)))
|
||
(slt2 (smart-list-tail fp num)))
|
||
(if (atom? slt1)
|
||
(not-enough-elements-error n)
|
||
(set-cdr! slt1
|
||
(append! v slt2)))))))
|
||
)))
|
||
;--------------------------------------------------------------------;
|
||
; INSERT BEFORE ;
|
||
; arguments num: The nth element of the FP ;
|
||
; v : The value being placed before the nth element ;
|
||
; Makes sure that the v can be inserted the calls splice-before ;
|
||
; with num and (list v). ;
|
||
;--------------------------------------------------------------------;
|
||
(insert-before
|
||
(lambda (num v)
|
||
(cond ((atom? fp)
|
||
(newline)
|
||
(writeln
|
||
" ? FP is an atom, can't insert before "
|
||
n " element"))
|
||
(t (splice-before num (cons v nil))))))
|
||
;--------------------------------------------------------------------;
|
||
; INSERT AFTER ;
|
||
; arguments num: The nth element of the FP ;
|
||
; v : The value being placed after the nth element ;
|
||
; Makes sure that the v can be inserted the calls splice-after ;
|
||
; with num and (list v). ;
|
||
;--------------------------------------------------------------------;
|
||
(insert-after
|
||
(lambda (num v)
|
||
(cond ((atom? fp)
|
||
(newline)
|
||
(writeln
|
||
" ? FP is an atom, can't insert after "
|
||
n " element"))
|
||
(t (splice-after num (cons v nil))))))
|
||
;--------------------------------------------------------------------;
|
||
; ;
|
||
; Help Functions ;
|
||
; ;
|
||
;--------------------------------------------------------------------;
|
||
|
||
(push
|
||
(lambda (l pos)
|
||
(set! stack (cons (list* l pos) stack))))
|
||
|
||
(pop
|
||
(lambda ()
|
||
(if (null? (cdr stack))
|
||
'cannot-pop-stack
|
||
(begin0 (car stack)
|
||
(set! stack (cdr stack))))))
|
||
|
||
(fp-part car)
|
||
|
||
(element-part cdr)
|
||
;----------------------------------------------------------;
|
||
; Print depth length ;
|
||
; It will return a list with depth of print-level and ;
|
||
; length of print-length. It will replace all levels ;
|
||
; lower than print-level with # and all elements further ;
|
||
; than print-length with ... ;
|
||
;----------------------------------------------------------;
|
||
|
||
(print-depth-length
|
||
(letrec ((p1 0)
|
||
(loop
|
||
(lambda (l lev len)
|
||
(cond ((<= len 0) '(...))
|
||
((atom? l) l)
|
||
((<= lev 0) '#\#)
|
||
((atom? (car l))
|
||
(cons (car l)
|
||
(loop (cdr l) lev (-1+ len))))
|
||
(t (cons (loop (car l) (-1+ lev) p1)
|
||
(loop (cdr l) lev (-1+ len)))))))
|
||
)
|
||
(lambda (l print-level print-length)
|
||
(set! p1 print-length)
|
||
(loop l print-level print-length) )))
|
||
|
||
(list-length ; Gives list-length while checking for
|
||
(lambda (l) ; circular lists. Returns nil
|
||
(letrec ((loop (lambda () ; if circular list is found
|
||
(cond ((atom? fast) n)
|
||
((atom? (cdr fast)) (+ n 1))
|
||
((and (eq? fast slow) (> n 0)) nil)
|
||
(t (set! fast (cddr fast))
|
||
(set! slow (cdr slow))
|
||
(set! n (+ n 2))
|
||
(loop)))))
|
||
(n 0)
|
||
(fast l)
|
||
(slow l))
|
||
(loop))))
|
||
|
||
(correct-position ; If number is negative, translates it
|
||
(lambda (n) ; the equivalent positive number.
|
||
(if (< n 0)
|
||
(+ (list-length fp) (1+ n))
|
||
n)))
|
||
|
||
;----------------------------------------------------------;
|
||
; Smart-list-ref ;
|
||
; Returns a pair. The first of which is the list-ref of ;
|
||
; l. The second is the number left over. This number ;
|
||
; will be zero unless the number is larger than the number;
|
||
; of elements in the list. Then it will show the number ;
|
||
; left and return the last element. ;
|
||
;----------------------------------------------------------;
|
||
(smart-list-ref
|
||
(lambda (l n)
|
||
(cond ((atom? l) nil)
|
||
((atom? (cdr l)) (cons (car l) n))
|
||
((zero? n) (cons (car l) 0))
|
||
(t (smart-list-ref (cdr l) (-1+ n))))))
|
||
|
||
(at-top-level?
|
||
(lambda () (null? (cdr stack))))
|
||
;----------------------------------------------------------;
|
||
; Correct-stack ;
|
||
; Corrects the parent of the FP when the FP is changed ;
|
||
; with a set! instead of set-car! or set-cdr! ;
|
||
;----------------------------------------------------------;
|
||
|
||
(correct-stack
|
||
(lambda (l)
|
||
(let ((par (parent stack)))
|
||
(if (eq? (element-part par) '*)
|
||
(if (atom? l)
|
||
(set-cdr! (last-pair (fp-part par)) l)
|
||
(let ((stack-frame (pop)))
|
||
(set! fp (fp-part stack-frame))
|
||
(set-cdr! (last-pair fp) l)))
|
||
(set-car! (if (= (element-part par) 1)
|
||
(fp-part par)
|
||
(list-tail (fp-part par)
|
||
(-1+ (element-part par))))
|
||
l)))))
|
||
|
||
(list?
|
||
(lambda (l)
|
||
(and (pair? l)
|
||
(null? (cdr (last-pair l))))))
|
||
|
||
;----------------------------------------------------------;
|
||
; List-ref-* ;
|
||
; Used in Find. It is set up to know about the *th ;
|
||
; position. It counts the * as another element. Other ;
|
||
; than this, it is just like smart-list-ref. ;
|
||
;----------------------------------------------------------;
|
||
(list-ref-*
|
||
(lambda (l n)
|
||
(cond ((atom? l) (cons l '*))
|
||
((zero? n) (cons (car l) 0))
|
||
(t (list-ref-* (cdr l) (-1+ n))))))
|
||
|
||
(parent car)
|
||
|
||
;----------------------------------------------------------;
|
||
; Smart-list-tail ;
|
||
; This is used in the modifying commands. It allows the ;
|
||
; calling function to figure out if there is an nth ;
|
||
; element. An atom is returned if it there are not n ;
|
||
; elements. The value of this command is used in set-car!;
|
||
; and set-cdr!. Thus it cannot be an atom. ;
|
||
;----------------------------------------------------------;
|
||
(smart-list-tail
|
||
(letrec ((loop
|
||
(lambda (l n)
|
||
(cond ((zero? n) l)
|
||
((atom? l) '**atom-returned**) ;PRK 53085
|
||
(t (loop (cdr l) (-1+ n)))))))
|
||
(lambda (l n)
|
||
(if (< n 0)
|
||
'**atom-returned**
|
||
(loop l n)))))
|
||
|
||
(not-enough-elements-error
|
||
(lambda (n)
|
||
(newline)
|
||
(writeln " ? There are not " n " elements")))
|
||
|
||
(circular-error
|
||
(lambda (n)
|
||
(newline)
|
||
(writeln
|
||
" ? FP is a circular list, can't use negative numbers: "
|
||
n)))
|
||
|
||
(arg?
|
||
(lambda (a)
|
||
(let ((x (explode a)))
|
||
(if (eq? (car x) '#\#)
|
||
(if (number-range? (cdr x))
|
||
(symbols->number (cdr x) 10 0)
|
||
#!false)
|
||
#!false))))
|
||
|
||
(number-range?
|
||
(lambda (l)
|
||
(if (null? l)
|
||
#!true
|
||
(let ((a (symbol->ascii (car l))))
|
||
(if (and (> a 47) (< a 58))
|
||
(number-range? (cdr l))
|
||
#!false)))))
|
||
|
||
(symbols->number
|
||
(lambda (l b n)
|
||
(if (null? l)
|
||
0
|
||
(+ (symbols->number (cdr l) b (1+ n))
|
||
(* (expt b n)
|
||
(- (symbol->ascii (car l)) 48))))))
|
||
|
||
;--------------------------------------------------------------------;
|
||
; ;
|
||
; Variables ;
|
||
; ;
|
||
;--------------------------------------------------------------------;
|
||
|
||
(very-top nil)
|
||
(initial-stack nil)
|
||
(fp nil)
|
||
(stack nil)
|
||
(command nil)
|
||
(done? nil)
|
||
(buffer nil)
|
||
|
||
|
||
;--------------------------------------------------------------------;
|
||
; ;
|
||
; Debugging Functions ;
|
||
; ;
|
||
;--------------------------------------------------------------------;
|
||
|
||
(ps (lambda () (print (print-depth-length stack 4 10))))
|
||
|
||
|
||
)
|
||
|
||
(lambda (l)
|
||
(set! done? nil)
|
||
(set! fp l)
|
||
(set! very-top (list fp))
|
||
(set! initial-stack (list (list* very-top 1)))
|
||
(set! stack initial-stack)
|
||
(read-eval-print-loop))))
|
||
|
||
|