CLISP Macros#

General Information

Author: Datasoft
Language: LISP
Compiler/Interpreter: InterLisp/65


(CLISP TRANSLATE WEIGHT OPCODE)
(DEFINEQ CLISP '(LAMBDA (FUN) (DEFINE FUN (TRANSLATE (GETD FUN))))
)
(DEFINEQ TRANSLATE '(LAMBDA (S-EXP) (PROG (OPERANDS OPERATORS) (COND ((ATOM S-EXP) (RETURN S-EXP))) (COND ((EQ (OPCODE (CAR (CDR S-EXP)))) (RETURN (MAPCAR S-EXP (QUOTE TRANSLATE))))) (SETQ OPERATORS (QUOTE (DUMMY))) STUFF (COND ((EQ S-EXP) (COND ((EQ (CAR OPERATORS) (QUOTE DUMMY)) (RETURN (QUOTE *ERROR*))) (T (RETURN (LIST (TRANSLATE (CAR OPERANDS)) (TRANSLATE (CAR OPERATORS)))))))) (SETQ OPERANDS (CONS (COND ((ATOM (CAR S-EXP)) (CAR S-EXP)) ((TRANSLATE (CAR S-EXP)))) OPERANDS)) (SETQ S-EXP (CDR S-EXP)) SCAN (COND ((AND (EQ S-EXP) (EQ (CAR OPERATORS) (QUOTE DUMMY))) (RETURN (CAR OPERANDS)))) (COND ((OR (EQ S-EXP) (EQ (> (WEIGHT (CAR S-EXP)) (WEIGHT (CAR OPERATORS))))) (SETQ OPERANDS ((LAMBDA (X) (COND ((EQ X) (CONS (LIST (CAR (CDR OPERANDS)) (CAR OPERATORS) (CAR OPERANDS)) (CDR (CDR OPERANDS)))) (T (CONS (LIST X (CAR (CDR OPERANDS)) (CAR OPERANDS)) (CDR (CDR OPERANDS)))))) (OPCODE (CAR OPERATORS)))) (SETQ OPERATORS (CDR OPERATORS)) (GO SCAN)) (T (SETQ OPERATORS (CONS (CAR S-EXP) OPERATORS)) (SETQ S-EXP (CDR S-EXP)) (GO STUFF)))))
)
(DEFINEQ WEIGHT '(LAMBDA (OP) (COND ((EQ OP (QUOTE DUMMY)) -1) ((EQ OP (QUOTE =)) 0) ((EQ OP (QUOTE +)) 1) ((EQ OP (QUOTE -)) 1) ((EQ OP (QUOTE *)) 2) ((EQ OP (QUOTE /)) 2) (T 4)))
)
(DEFINEQ OPCODE '(LAMBDA (OP) (COND ((EQ OP (QUOTE DUMMY)) (QUOTE DUMMY)) ((EQ OP (QUOTE =)) (QUOTE SETQ)) ((EQ OP (QUOTE +)) (QUOTE +)) ((EQ OP (QUOTE -)) (QUOTE SUB)) ((EQ OP (QUOTE *)) (QUOTE *)) ((EQ OP (QUOTE /)) (QUOTE /))))
)
NIL

Add new attachment

Only authorized users are allowed to upload new attachments.
« This page (revision-2) was last changed on 14-Mar-2010 11:21 by Carsten Strotmann