View file src/lpian/link.lpi - Download

(

(synonym KI J)

(def LINK-LABEL 'label)
(def LINK-GOTO 'goto)

(def LINK : LIST1 LINK1 CAR)

(def LINK1 :
	'() ARG labels :
	LINK2 ARG y :
	'() ARG linked :
	%y LINK3
	(Y :
		%linked NOT THEN EXIT :
		'() SETVQ linked
		%y LINK3)
	%y)

(def LINK2 : ARG x :
	%x NCONSPTHEN %x :
	(%x CAR NCONSPTHEN '() :
	 %x CAR CAR LINK-LABEL EQ)
	THEN (%x CDR LINK2 ARG y :
		@(labels SETVQ
			CONS CONS CAR CDR CAR %x CONS %y '()
				%labels)
		%y) :
	@:CONS LINK2 CAR %x LINK2 CDR %x)

(def LINK3 :
	'() SETVQ LINK-DEJAVU
	LINK4)

(def LINK4 : ARG x :
	%x %LINK-DEJAVU MEMQ THEN I :
	%x NCONSPTHEN I :
	%LINK-DEJAVU %x CONS SETVQ LINK-DEJAVU
	%x CAR LINK4 %x CDR LINK4
	(%x CAR NCONSPTHEN '() :
	 %x CAR CAR NCONSPTHEN '() :
	 LINK-GOTO %x CAR CAR CAR EQ)
	THEN ('true SETVQ linked
		%x CAR CAR CDR CDR %labels GETVENV
		%x RPLACA) :
	(%x CDR NCONSPTHEN '() :
	 %x CDR CAR NCONSPTHEN '() :
	 LINK-GOTO %x CDR CAR CAR EQ)
	THEN ('true SETVQ linked
		%x CDR CAR CDR CAR %labels GETVENV
		%x RPLACD)
	I)


(def GETPAIRS : ARG x :
    '() ARG pairs :
    %x GETPAIRS1
    %pairs 
)

(def GETPAIRS1 : ARG x :
    %x NCONSPTHEN I :
    %pairs %x CONTIENT (ARG x : ARG ly :                    
                        %x %ly CDR EQ AND (GENSYM ARG l : '() %l CONS LINK-LABEL CONS %ly RPLACA 't)) THEN I :
    %pairs %x '() CONS CONS SETVQ pairs :
    %x CAR GETPAIRS1
    %x CDR GETPAIRS1
)

(def UNLINK : ARG x :
    %x GETPAIRS ARG pairs :
    %x UNLINK1
)

(def UNLINK1 : ARG x :
    %x NCONSPTHEN %x :
    %pairs %x CONTIENT (ARG x : ARG ly :
                        %x %ly CDR EQ AND %ly) ARG ly1 :
    %ly1 NOT THEN (%x CAR UNLINK1 %x CDR UNLINK1 ECH CONS) :
    %ly1 CAR NOT THEN (%x CAR UNLINK1 %x CDR UNLINK1 ECH CONS) :
    %ly1 CAR CAR LINK-LABEL EQ THEN (LINK-GOTO %ly1 CAR RPLACA
                                 %ly1 CAR CDR CAR ARG label :                                   
                                 %x CAR UNLINK1 %x CDR UNLINK1 ECH CONS
                                 '() %label CONS LINK-LABEL CONS CONS) :
    %ly1 CAR CAR LINK-GOTO EQ THEN (%ly1 CAR CDR CAR ARG label : '() '() %label CONS LINK-GOTO CONS CONS) :
    %('ERROR ly1)
)
     
(def TESTLINK :
    '((label l) a b c (d e f (goto l)) g h i ((label m) j k l (goto m)) m n o (goto l)) ARG x :
    %x PRINT
    %x LINK UNLINK PRINT)
    
TESTLINK
     
)