Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
00010 BEGIN NEW INLEVEL,I,L; SPECIAL I,INLEVEL,FIRST,REST,ELSEINDENT,INDNT;
00020 % LISP-TO-MLISP TRANSLATOR.
00030 TO CONVERT A LISP FILE TO MLISP, SAY "CONVERT(<FILE NAME>)".
00040 THE FILE TO BE CONVERTED MUST BE ON YOUR AREA OF THE DISK AND HAVE NO EXTENSION.
00050 THE CONVERTED FILE IS PUT ON <FILE NAME>.MLP . %
00060
00070 FEXPR CONVERT (FILENAME);
00080 % THE ARGUMENTS TO 'CONVERT' ARE EITHER:
00090 (1) A FILENAME, IN WHICH CASE DEVICE DSK: IS ASSUMED, OR
00100 (2) A SOURCE AND FILENAME, SUCH AS
00110 DTA1: <FILENAME>
00120 MTA0: <FILENAME>
00130 (1 DAV) <FILENAME> . %
00140 BEGIN NEW X,EVALQUOTE; SPECIAL X,EVALQUOTE;
00150 DDTIN(T);
00160 TERPRI();
00170 PRINC("IBASE=");
00180 IBASE _ READ(); % THIS IS THE RADIX FOR NUMBERS IN THE FILE. %
00190 TERPRI();
00200 PRINC("EVALQUOTE (Y OR N)? "); % IS THE FILE IN EVALQUOTE FORMAT? %
00210 DO X _ READCH() UNTIL (X EQ 'Y) | (X EQ 'N);
00220 IF X EQ 'Y THEN EVALQUOTE _ T;
00230 TERPRI();
00240 DDTIN(NIL);
00250 IF CDR(FILENAME) THEN PROG2(EVAL('INPUT CONS FILENAME),FILENAME _ F2(FILENAME))
00260 ELSE PROG2(EVAL('INPUT CONS 'DSK: CONS FILENAME),FILENAME _ CAR(FILENAME));
00270 INC(T,T);
00280 DDTOUT(NIL);
00290 EVAL(<'OUTPUT,'DSK:,FILENAME CONS 'MLP>); % .MPL IS THE EXTENSION FOR CONVERTED FILES. %
00300 OUTC(T,T);
00310 CSYM(???&G00); % A MAXIMUM OF 100 COND'S WITHOUT EXPRESSIONS (C.F. 'TCOND') ARE PERMITTED. %
00320 INLEVEL _ 0;
00330 PRINCHECK("BEGIN");
00340 TERPRI(); TERPRI();
00350 WHILE NOT ATOM X _ ERRSET(READ(),T) DO
00360 IF EVALQUOTE THEN TOPLEVEL(CAR(X) CONS READ(),DEFINETEST(CAR(X))) ELSE TOPLEVEL(CAR(X),T);
00370 PRINCHECK("END.");
00380 TERPRI();
00390 OUTC(NIL,T);
00400 DDTOUT(T);
00410 INC(NIL,T); IBASE _ 10.;
00420 RETURN('FINISHED);
00430 END;
00440
00450 EXPR TOPLEVEL (X,PRINTSEMI);
00460 BEGIN
00470 MEXPR(X,NIL,T);
00480 IF PRINTSEMI THEN BEGIN PRINCHECK(";"); TERPRI(); TERPRI() END;
00490 END;
00500
00510 EXPR INDENT (X);
00520 % THIS KEEPS TRACK OF THE INDENTATION LEVEL. %
00530 IF X THEN INLEVEL _ INLEVEL + 1 ELSE INLEVEL _ INLEVEL - 1;
00540
00550 EXPR INPRINT ();
00560 % THIS STARTS A NEW LINE AND INDENTS THE NUMBER OF SPACES SPECIFIED BY 'INLEVEL'. %
00570 BEGIN
00580 TERPRI();
00590 FOR NEW I_1 TO INLEVEL DO PRINCHECK(" ");
00600 END;
00610
00620 EXPR INDENTP (X); PROG2(INDENT(X),INPRINT());
00630
00640 EXPR MEXPR (SEXPR,INDNT,ELSEINDENT);
00650 % ALL FUNCTIONS MUST LEAVE THE POINTER IN THE CORRECT LOCATION FOR THE NEXT FUNCTION TO BEGIN PRINTING. %
00660 IF ATOM SEXPR THEN ATOMPRINC(SEXPR) ELSE MEXPR1(CAR(SEXPR),CDR(SEXPR),INDNT,ELSEINDENT);
00670
00680 EXPR MEXPR1 (FIRST,REST,INDNT,ELSEINDENT);
00690 % 'FIRST' IS THE FUNCTION NAME CURRENTLY BEING DEALT WITH. %
00700 % 'REST' IS ITS ARGUMENT LIST. %
00710 % 'INDNT' CONTROLS WHETHER OR NOT A SPECIAL FUNCTION (Q.V.) IS INDENTED. %
00720 % 'ELSEINDENT' CONTROLS WHETHER OR NOT THE 'ELSE' PART OF A CONDITIONAL IS INDENTED. %
00730 IF ATOM FIRST THEN
00740 IF NUMBERP FIRST THEN TFUNC(FIRST,REST) ELSE
00750 IF GET(FIRST,'SPECIALFUNC) THEN
00760 BEGIN
00770 IF INDNT THEN INDENTP(T);
00780 IF (FIRST EQ 'COND) & CONDTEST(REST) THEN ELSEINDENT _ NIL;
00790 EVAL(GET(FIRST,'SPECIALFUNC));
00800 IF INDNT THEN INDENT(NIL);
00810 END ELSE
00820 IF GET(FIRST,'SPECIALFUNC1) THEN EVAL(GET(FIRST,'SPECIALFUNC1)) ELSE
00830 IF GET(FIRST,'ABBREV) | (LENGTH(REST) = 2) & FIRST NEQ 'LIST THEN % MAKE THE FUNCTION AN INFIX. %
00840 BEGIN NEW PT;
00850 PT _ PARENTEST(CAR(REST));
00860 IF PT THEN PRINCHECK(LPAR);
00870 MEXPR(CAR(REST),T,NIL);
00880 IF PT THEN PRINCHECK(RPAR);
00890 PRINCHECK(BLANK);
00900 IF GET(FIRST,'ABBREV) THEN PRINCHECK(GET(FIRST,'ABBREV)) ELSE ATOMPRINC(FIRST);
00910 PRINCHECK(BLANK);
00920 IF LENGTH(REST) = 2 THEN MEXPR(F2(REST),T,NIL) ELSE MEXPR(FIRST CONS CDR(REST),T,NIL);
00930 END ELSE
00940 IF GET(FIRST,'PREFIX) & PREFIXTEST(CAR(REST)) THEN
00950 BEGIN
00960 PRINCHECK(GET(FIRST,'PREFIX));
00970 IF FIRST NEQ 'MINUS THEN PRINCHECK(BLANK);
00980 MEXPR(CAR(REST),T,NIL);
00990 END
01000 ELSE TFUNC(FIRST,REST) ELSE
01010 IF CAR(FIRST) EQ 'LAMBDA THEN TLAMBDA(CDR(FIRST),REST,INDNT)
01020 ELSE BEGIN
01030 MEXPR(FIRST,T,T);
01040 PRINCHECK(LPAR);
01050 TARGS(REST);
01060 PRINCHECK(RPAR);
01070 END;
01080
01090 EXPR TPROG (L);
01100 BEGIN NEW INDNT; SPECIAL INDNT;
01110 PRINCHECK("BEGIN");
01120 INDENT(T);
01130 IF CAR(L) THEN
01140 BEGIN
01150 INPRINT();
01160 PRINCHECK("NEW ");
01170 TARGS(CAR(L));
01180 PRINCHECK(";");
01190 END;
01200 INDNT _ T;
01210 FOR NEW I IN CDR(L) DO
01220 IF ATOM I THEN % I IS A LABEL. %
01230 BEGIN
01240 INDENTP(NIL);
01250 ATOMPRINC(I);
01260 PRINCHECK("; ");
01270 INDENT(T);
01280 IF LENGTH(EXPLODE(I)) = 1 THEN INDNT _ NIL ELSE INDNT _ T;
01290 END ELSE
01300 BEGIN
01310 IF INDNT THEN INPRINT() ELSE INDNT _ T; % 'INDNT' IS NIL ONLY IF THE PREVIOUS %
01320 MEXPR(I,NIL,T); % ELEMENT OF THE PROG WAS A ONE-LETTER LABEL. %
01330 PRINCHECK(";");
01340 END;
01350 INDENTP(NIL);
01360 PRINCHECK("END");
01370 END;
01380
01390 EXPR TCOND (L,ELSEINDENT);
01400 IF NULL L THEN NIL ELSE
01410 IF NULL CDAR(L) THEN % WE HAVE A PREDICATE WITHOUT A CORRESPONDING EXPRESSION. %
01420 BEGIN NEW COUNTER;
01430 COUNTER _ GENSYM();
01440 PRINCHECK("IF " CAT COUNTER CAT " _ ");
01450 MEXPR(CAAR(L),T,T);
01460 PRINCHECK(" THEN " CAT COUNTER);
01470 TCOND1(CDR(L),ELSEINDENT);
01480 END ELSE
01490 BEGIN
01500 PRINCHECK("IF ");
01510 MEXPR(CAAR(L),T,T);
01520 PRINCHECK(" THEN ");
01530 TTHEN(CDAR(L));
01540 IF NOT ATOM CADAR(L) & SPECIALTEST(CAADAR(L)) THEN TCOND1(CDR(L),T) ELSE TCOND1(CDR(L),ELSEINDENT);
01550 END;
01560
01570 EXPR TCOND1 (L,ELSEINDENT);
01580 IF NULL L THEN NIL ELSE
01590 IF CAAR(L) EQ 'T THEN TELSE(CDAR(L),ELSEINDENT) ELSE
01600 BEGIN
01610 PRINCHECK(" ELSE");
01620 INPRINT();
01630 TCOND(L,T);
01640 END;
01650
01660 EXPR TTHEN (L);
01670 IF CDR(L) THEN MEXPR(MTO(L),T,T) ELSE TTHEN1(CAR(L));
01680
01690 EXPR TTHEN1 (SEXP);
01700 IF NOT ATOM SEXP & CAR(SEXP) EQ 'PROG THEN PROG2(INPRINT(),MEXPR(SEXP,NIL,T)) ELSE MEXPR(SEXP,T,T);
01710
01720 EXPR TELSE (L,ELSEINDENT);
01730 IF NULL CDR(L) & NOT ATOM CAR(L) & GET1(CAAR(L),'SPECIALFUNC) THEN
01740 BEGIN
01750 PRINCHECK(" ELSE");
01760 INPRINT();
01770 MEXPR(CAR(L),NIL,T);
01780 END ELSE
01790 IF NOT ELSEINDENT & NULL CDR(L) THEN PROG2(PRINCHECK(" ELSE "),MEXPR(CAR(L),T,T))ELSE
01800 BEGIN
01810 INPRINT();
01820 PRINCHECK("ELSE ");
01830 MEXPR(MTO(L),T,T);
01840 END;
01850
01860 EXPR MTO (L);
01870 % THIS TAKES CARE OF ANY COND PARTS THAT HAVE MORE THAN ONE (MTO) EXPRESSION FOLLOWING THE PREDICATE. %
01880 IF CDR(L) THEN
01890 'AND CONS FOR NEW I IN L COLLECT
01900 IF NOT ATOM I & (CAR(I) EQ 'GO) | (CAR(I) EQ 'RETURN) THEN <I> ELSE <<'PROG2,I,T>>
01910 ELSE CAR(L);
01920
01930 EXPR TDEFPROP (L);
01940 IF F3(L) '(EXPR FEXPR MACRO LEXPR) THEN
01950 BEGIN
01960 PRINCHECK(F3(L) CAT BLANK);
01970 ATOMPRINC(CAR(L));
01980 PRINCHECK(" ("); TARGS(F2(F2(L))); PRINCHECK("); ");
01990 MEXPR(F3(F2(L)),T,T);
02000 END
02010 ELSE BEGIN
02020 PRINCHECK("PUTPROP(");
02030 TARGS(FOR NEW I IN L COLLECT <<'QUOTE,I>>);
02040 PRINCHECK(RPAR);
02050 END;
02060
02070 EXPR TDEFPROP1 (FIRST,REST);
02080 TDEFPROP(<CAR(REST),<'LAMBDA,F2(REST),F3(REST)>,
02090 IF FIRST EQ 'DE THEN 'EXPR ELSE
02100 IF FIRST EQ 'DF THEN 'FEXPR ELSE 'MACRO>);
02110
02120 EXPR TDEFINE (FIRST,REST);
02130 FOR NEW I IN CAR(REST) DO TOPLEVEL(<'DEFPROP,CAR(I),F2(I),
02140 IF FIRST EQ 'DEFINE THEN 'EXPR ELSE
02150 IF FIRST EQ 'DEFEXPR THEN 'FEXPR ELSE 'MACRO>,T);
02160
02170 EXPR TFUNC (FIRST,REST);
02180 IF GET1(FIRST,'SPECIALFUNC2) THEN EVAL(GET(FIRST,'SPECIALFUNC2)) ELSE
02190 BEGIN
02200 ATOMPRINC(FIRST);
02210 PRINCHECK(LPAR);
02220 TARGS(REST);
02230 PRINCHECK(RPAR);
02240 END;
02250
02260 EXPR TARGS (L);
02270 IF L THEN
02280 BEGIN
02290 MEXPR(CAR(L),T,NIL);
02300 FOR NEW I IN CDR(L) DO PROG2(PRINCHECK(COMMA),MEXPR(I,T,NIL));
02310 END;
02320
02330 EXPR TLAMBDA (L,ARGS,INDNT);
02340 BEGIN
02350 IF ARGS & INDNT THEN INDENTP(T);
02360 PRINCHECK("LAMBDA (");
02370 TARGS(CAR(L));
02380 PRINCHECK("); ");
02390 IF ARGS THEN
02400 BEGIN
02410 INDENTP(T);
02420 MEXPR(F2(L),NIL,T); PRINCHECK(";");
02430 INDENTP(NIL);
02440 PRINCHECK(LPAR);
02450 TARGS(ARGS);
02460 PRINCHECK(RPAR);
02470 IF INDNT THEN INDENT(NIL);
02480 END
02490 ELSE MEXPR(F2(L),T,T);
02500 END;
02510
02520 EXPR TCAR (FIRST,ARG);
02530 IF NOT ATOM ARG & FIELDTEST(FIRST,GET1(CAR(ARG),'MOREFIELD)) THEN
02540 TCAR(FIRST + GET(CAR(ARG),'MOREFIELD),F2(ARG))
02550 ELSE BEGIN
02560 PRINTEST("CAR(");
02570 PRINC("F" CAT FIRST CAT LPAR);
02580 MEXPR(ARG,T,T);
02590 PRINCHECK(RPAR);
02600 END;
02610
02620 EXPR TQUOTE (SEXP);
02630 IF CAR(EXPLODE(SEXP)) EQ DBQUOTE THEN PRIN1(SEXP) ELSE PROG2(PRINCHECK("'"),LISTPRINC(SEXP));
02640
02650 EXPR TLIST (L);
02660 BEGIN
02670 PRINCHECK("<");
02680 TARGS(L);
02690 PRINCHECK(">");
02700 END;
02710
02720 EXPR PRINCHECK (X); PROG2(PRINTEST(X),PRINC(X));
02730
02740 EXPR PRINTEST (X); IF FLATSIZE(X) GREATERP CHRCT() THEN PROG2(INPRINT(),PRINC(" "));
02750
02760 EXPR FIELDTEST (X,Y); Y & (X + Y) LESSP 10;
02770
02780 EXPR PARENTEST (X); NOT ATOM X & (GET1(CAR(X),'SPECIALFUNC) | LENGTH(X) = 3);
02790
02800 EXPR PREFIXTEST (X);
02810 ATOM X | (NOT (LENGTH(X)=3) & NOT GET1(CAR(X),'SPECIALFUNC) & NOT GET1(CAR(X),'SPECIALFUNC1));
02820
02830 EXPR CONDTEST (X);
02840 (FLATSIZE(X) LESSP CHRCT()) & (ATOM CAAR(X) | NOT SPECIALTEST(CAAAR(X)))
02850 & (NULL CDAR(X) | ATOM CADAR(X) | NOT SPECIALTEST(CAADAR(X)));
02860
02870 EXPR SPECIALTEST (X); GET1(X,'SPECIALFUNC) | GET1(X,'SPECIALFUNC1);
02880
02890 EXPR DEFINETEST (X); (X NEQ 'DEFINE) & (X NEQ 'DEFEXPR) & (X NEQ 'MACRO);
02900
02910 EXPR LISTPRINC (SEXP);
02920 IF GET1(SEXP,'RESERVEDWORD) THEN PRINCHECK(SEXP) ELSE
02930 IF ATOM SEXP THEN ATOMPRINC(SEXP) ELSE
02940 BEGIN
02950 PRINCHECK(LPAR);
02960 LISTPRINC(CAR(SEXP));
02970 LISTPRINC1(CDR(SEXP));
02980 PRINCHECK(RPAR);
02990 END;
03000
03010 EXPR LISTPRINC1 (L);
03020 IF NULL L THEN NIL ELSE
03030 IF ATOM L THEN PROG2(PRINCHECK(" . "),ATOMPRINC(L)) ELSE
03040 BEGIN
03050 PRINCHECK(BLANK);
03060 LISTPRINC(CAR(L));
03070 LISTPRINC1(CDR(L));
03080 END;
03090
03100 EXPR ATOMPRINC (AT);
03110 IF NUMBERP AT THEN PRINCHECK(AT) ELSE
03120 BEGIN
03130 PRINTEST(AT);
03140 FOR NEW I IN EXPLODEC(AT) DO
03150 IF NUMBERP I | GET(I,'LETTER) THEN PRINC(I) ELSE PROG2(PRINC('??),PRINC(I));
03160 IF GET(AT,'RESERVEDWORD) THEN
03170 BEGIN NEW N;
03180 N _ CHRCT();
03190 TERPRI();
03200 PRINTSTR("*** WARNING ***, " CAT AT CAT " IS A RESERVED WORD IN MLISP.");
03210 FOR NEW I_1 TO CHRCT() - N DO PRINC(BLANK);
03220 END;
03230 END;
03240
03250 EXPR GET1 (AT,IND); ATOM AT & NOT NUMBERP AT & GET(AT,IND);
03260
03270 L _ '((SETQ . ?_) (PLUS . ?+) (DIFFERENCE . ?-) (TIMES . ?*) (QUOTIENT . ?/) (AND . ?&) (OR . ?|) (EQUAL . ?=)
03280 (NEQUAL . ?) (APPEND . ?@) (MEMBER . ?));
03290
03300 FOR I IN L DO PUTPROP(CAR(I),CDR(I),'ABBREV);
03310
03320
03330 L _ '((MINUS . ?-) (NOT . NOT) (NULL . NULL) (ATOM . ATOM) (NUMBERP . NUMBERP));
03340
03350 FOR I IN L DO PUTPROP(CAR(I),CDR(I),'PREFIX);
03360
03370
03380 L _ '((CADR . 2) (CADDR . 3) (CADDDR . 4));
03390
03400 FOR I IN L DO PUTPROP(CAR(I),CDR(I),'FIELD);
03410
03420
03430 L _ '((CDR . 1) (CDDR . 2) (CDDDR . 3) (CDDDDR . 4));
03440
03450 FOR I IN L DO PUTPROP(CAR(I),CDR(I),'MOREFIELD);
03460
03470
03480 L _ '(
03490 ((TPROG REST) . PROG)
03500 ((TCOND REST ELSEINDENT) . COND)
03510 ((TDEFPROP1 FIRST REST) . DE)
03520 ((TDEFPROP1 FIRST REST) . DF)
03530 ((TDEFPROP1 FIRST REST) . DM)
03540 ((TDEFINE FIRST REST) . DEFINE)
03550 ((TDEFINE FIRST REST) . DEFEXPR)
03560 ((TDEFINE FIRST REST) . MACRO));
03570
03580 FOR I IN L DO PUTPROP(CDR(I),CAR(I),'SPECIALFUNC);
03590
03600
03610 L _ '(
03620 ((TDEFPROP REST) . DEFPROP)
03630 ((TLAMBDA REST NIL INDNT) . LAMBDA));
03640
03650 FOR I IN L DO PUTPROP(CDR(I),CAR(I),'SPECIALFUNC1);
03660
03670
03680 L _ '(
03690 ((TQUOTE (F1 REST)) . QUOTE)
03700 ((TLIST REST) . LIST)
03710 ((TCAR 2 (F1 REST)) . CADR)
03720 ((TCAR 3 (F1 REST)) . CADDR)
03730 ((TCAR 4 (F1 REST)) . CADDDR));
03740
03750 FOR I IN L DO PUTPROP(CDR(I),CAR(I),'SPECIALFUNC2);
03760
03770
03780 FOR I IN '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z ! :) DO PUTPROP(I,T,'LETTER);
03790
03800
03810 L _ '(BEGIN NEW SPECIAL END COLLECT UNTIL WHILE DO FOR IF THEN ELSE IN ON BY TO LAMBDA OCTAL);
03820
03830 FOR I IN L DO PUTPROP(I,T,'RESERVEDWORD);
03840
03850 END.