(SETQ ILISP @(EVALQUOTE1 APPLY1
                        LAM1
                        APP2
                        NULL*
                        LAM2
                        APP3
                        LAMS
                        UNFLICT
                        APPLY2
                        APPLY3
                        APPLY4
                        EVAL1
                        EVCON1
                        PAIRLIS
                        EVLIS1
                        SUBST1
                        SEARCH
                        SUBLIS
                        GENSYM
                        CSYM
                        CSYM#
                        CSYM$))

(DEFPROP EVALQUOTE1
(LAMBDA (FN X) (APPLY1 FN X NIL))
EXPR)

(DEFPROP APPLY1
(LAMBDA (FN X A)
 (COND
  ((ATOM FN)
   (COND
    ((GET FN EXPR) (APPLY1 (GET FN EXPR) X A))
    ((EQ FN CAR)
     (COND ((NULL* (CAR X)) CAR)
           ((LAM1 (CAR X)) (APP2 X CAR))
           (T (CAAR X))))
    ((EQ FN CDR)
     (COND ((NULL* (CAR X)) CDR)
           ((LAM1 (CAR X)) (APP2 X CDR))
           (T (CDAR X))))
    ((EQ FN CONS)
     (COND ((LAM2 X) (APP3 X A CONS)) (T (CONS (CAR X) (CADR X)))))
    ((EQ FN ATOM)
     (COND ((NULL* (CAR X)) ATOM)
           ((LAM1 (CAR X)) (APP2 X ATOM))
           (T (ATOM (CAR X)))))
    ((EQ FN EQ)
     (COND ((LAM2 X) (APP3 X A EQ)) (T (EQ (CAR X) (CADR X)))))
    (T (ERROR (LIST @APPLY1 FN X A)))))
  ((EQ (CAR FN) LAMBDA)
   (APPLY2 (LAMS (CONS LAMBDA (UNFLICT (CDR FN))) X) A))
  (T (ERROR (LIST @APPLY1 FN X A)))))
EXPR)

(DEFPROP LAM1
(LAMBDA (X) (AND (NOT (ATOM X)) (EQ (CAR X) LAMBDA)))
EXPR)

(DEFPROP APP2
(LAMBDA (X A) (LIST (CAAR X) (CADAR X) (LIST A (CADDAR X))))
EXPR)

(DEFPROP NULL*
(LAMBDA (X) (EQ X @NIL*))
EXPR)

(DEFPROP LAM2
(LAMBDA (X) (OR (MEMBER @NIL* X) (LAM1 (CAR X)) (LAM1 (CADR X))))
EXPR)

(DEFPROP APP3
(LAMBDA (X A F)
 ((LAMBDA (U V) (APPLY1 (LIST LAMBDA (LIST U V) (LIST F U V)) X A))
  (GENSYM)
  (GENSYM)))
EXPR)

(DEFPROP LAMS
(LAMBDA (FN X)
 (PROG (VAR1 ARG1 VARS ARGS ARG2 M L)
       (SETQ M (CADDR FN))
       (SETQ ARGS X)
       (SETQ VARS (CADR FN))
  LOOP (SETQ L (CAR ARGS))
       (COND ((LAM1 L) (GO FLICT)))
       (SETQ VAR1 (CONS (CAR VARS) VAR1))
       (SETQ ARG1 (CONS L ARG1))
  LOOP1(SETQ VARS (CDR VARS))
       (COND
        ((NULL VARS)
         (RETURN (LIST (REVERSE VAR1) M (REVERSE ARG1)))))
       (SETQ ARGS (CDR ARGS))
       (GO LOOP)
  FLICT(SETQ L (UNFLICT (CDR L)))
       (SETQ ARG2 (CAR L))
  LOOP2(SETQ VAR1 (CONS (CAR ARG2) VAR1))
       (SETQ ARG1 (CONS @NIL* ARG1))
       (SETQ ARG2 (CDR ARG2))
       (COND (ARG2 (GO LOOP2)))
       (SETQ M (SUBST (CADR L) (CAR VARS) M))
       (GO LOOP1)))
EXPR)

(DEFPROP UNFLICT
(LAMBDA (Y)
 (PROG (L)
       (SETQ L (CAR Y))
  LOOP (COND ((NULL L) (RETURN Y)))
       (SETQ Y (SUBST (GENSYM) (CAR L) Y))
       (SETQ L (CDR L))
       (GO LOOP)))
EXPR)

(DEFPROP APPLY2
(LAMBDA (L A)
 (COND ((MEMBER @NIL* (CADDR L)) (APPLY3 L A))
       (T (EVAL1 (CADR L) (PAIRLIS (CAR L) (CADDR L) A)))))
EXPR)

(DEFPROP APPLY3
(LAMBDA (L A)
 (SEARCH (CADDR L)
         (FUNCTION (LAMBDA (J) (NOT (EQ (CAR J) @NIL*))))
         (FUNCTION (LAMBDA (J) (APPLY4 L A)))
         (FUNCTION (LAMBDA (J) (LIST LAMBDA (CAR L) (CADR L))))))
EXPR)

(DEFPROP APPLY4
(LAMBDA (L A)
 (PROG (VARS FORM ARGS M ARG1)
       (SETQ VARS (CAR L))
       (SETQ FORM (CADR L))
       (SETQ ARGS (CADDR L))
  LOOP (SETQ ARG1 (CAR ARGS))
       (COND ((EQ ARG1 @NIL*) (GO B)))
       (SETQ FORM (SUBST (LIST QUOTE ARG1) (CAR VARS) FORM))
  LOOP1(SETQ ARGS (CDR ARGS))
       (COND ((NULL ARGS) (RETURN (LIST LAMBDA M FORM))))
       (SETQ VARS (CDR VARS))
       (GO LOOP)
  B    (SETQ M (CONS (CAR VARS) M))
       (GO LOOP1)))
EXPR)

(DEFPROP EVAL1
(LAMBDA (E A)
 (COND
  ((ATOM E)
   (COND ((ERRSET (EVAL E) NIL) (EVAL E))
         ((EQ E @NIL*) @NIL*)
         (T (CDR (ASSOC E A)))))
  ((ATOM (CAR E))
   (COND ((EQ (CAR E) QUOTE) (CADR E))
         ((EQ (CAR E) COND) (EVCON1 (CDR E) A))
         ((EQ (CAR E) LAMBDA) E)
         (T (APPLY1 (CAR E) (EVLIS1 (CDR E) A) A))))
  (T (APPLY1 (CAR E) (EVLIS1 (CDR E) A) A))))
EXPR)

(DEFPROP EVCON1
(LAMBDA (C A)
 ((LAMBDA (X)
   (COND
    ((LAM1 X)
     (LIST (CAR X)
           (CADR X)
           (CONS COND (CONS (LIST (CADDR X) (CADAR C)) (CDR C)))))
    ((EVAL1 X A) (EVAL1 (CADAR C) A))
    (T (EVCON1 (CDR C) A))))
  (CAAR C)))
EXPR)

(DEFPROP PAIRLIS
(LAMBDA (X Y A)
 (COND
  ((NULL X) A)
  (T (CONS (CONS (CAR X) (CAR Y)) (PAIRLIS (CDR X) (CDR Y) A)))))
EXPR)

(DEFPROP EVLIS1
(LAMBDA (M A)
 (COND ((NULL M) NIL)
       (T (CONS (EVAL1 (CAR M) A) (EVLIS1 (CDR M) A)))))
EXPR)

(DEFPROP SUBST1
(LAMBDA (X Y Z)
 (COND ((ATOM Z) (COND ((EQ Z Y) X) (T Z)))
       (T (CONS (SUBST1 X Y (CAR Z)) (SUBST1 X Y (CDR Z))))))
EXPR)

(DEFPROP SEARCH
(LAMBDA (%L %F1 %F2 %F3)
   L    ((ATOM %L) (RETURN (%F3 %L)))
        (COND ((%F1 %L) (RETURN (%F2 %L))))
        (SETQ %L (CDR %L))
        (GO L))
EXPR)

(DEFPROP SUBLIS
(LAMBDA (X Y)
 (COND
  ((NULL X) Y)
  ((NULL Y) Y)
  ((SEARCH
    X
    (FUNCTION (LAMBDA (J) (EQUAL Y (CAAR J))))
    (FUNCTION (LAMBDA (J) (CDAR J)))
    (FUNCTION
     (LAMBDA (J)
      (COND ((ATOM Y) Y)
            ((CONS (SUBLIS X (CAR Y)) (SUBLIS X (CDR Y)))))))))))
EXPR)

(DEFPROP GENSYM
(LAMBDA (BASE)
        (SETQ BASE 12)
        (SETQ CSYM# (ADD1 CSYM#))
        (RETURN (MAKNAM (APPEND CSYM$ (#EXPLODEC CSYM#)))))
EXPR)

(DEFPROP CSYM
(LAMBDA (X Y) (SETQ CSYM$ (#EXPLODEC X)) (SETQ CSYM# Y))
EXPR)

(SETQ CSYM# @0)

(SETQ CSYM$ @(107))

You are viewing proxied material from gopher.floodgap.com. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.