Artifact 4fc226a1187d6e6b5b94d203a679644b599cb7a39bcbe7d5a53efe756acbce74:
- File
r33/boot.sl
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7405) [annotate] [blame] [check-ins using] [more...]
% Standard LISP equivalent of BOOT.RED. (fluid '(!*blockp !*mode)) (global '(oldchan!*)) (global '(crchar!* cursym!* fname!* nxtsym!* ttype!* !$eol!$)) (put '!; 'switch!* '(nil !*semicol!*)) (put '!( 'switch!* '(nil !*lpar!*)) (put '!) 'switch!* '(nil !*rpar!*)) (put '!, 'switch!* '(nil !*comma!*)) (put '!. 'switch!* '(nil cons)) (put '!: 'switch!* '(((!= nil setq)) !*colon!*)) (put '!*comma!* 'infix 1) (put 'setq 'infix 2) (put 'cons 'infix 3) (flag '(!*comma!*) 'nary) (flag '(!*colon!* !*semicol!* end then else) 'delim) (put 'begin 'stat 'blockstat) (put 'if 'stat 'ifstat) (put 'symbolic 'stat 'procstat) (de begin2 nil (prog nil (setq cursym!* '!*semicol!*) a (cond ((eq cursym!* 'end) (progn (rds oldchan!*) (return nil))) (t (prin2 (errorset '(eval (form (xread nil))) t t)) )) (go a))) (de form (u) u) (de xread (u) (progn (scan) (xread1 u))) (de xread1 (u) (prog (v w x y z z2) a (setq z cursym!*) a1 (cond ((or (null (atom z)) (numberp z)) (setq y nil)) ((flagp z 'delim) (go end1)) ((eq z '!*lpar!*) (go lparen)) ((eq z '!*rpar!*) (go end1)) ((setq y (get z 'infix)) (go infx)) ((setq y (get z 'stat)) (go stat))) a3 (setq w (cons z w)) next (setq z (scan)) (go a1) lparen(setq y nil) (cond ((eq (scan) '!*rpar!*) (and w (setq w (cons (list (car w)) (cdr w)))) ) ((eqcar (setq z (xread1 'paren)) '!*comma!*) (setq w (cons (cons (car w) (cdr z)) (cdr w)))) (t (go a3))) (go next) infx (setq z2 (mkvar (car w) z)) un1 (setq w (cdr w)) (cond ((null w) (go un2)) (t (setq z2 (cons (car w) (list z2)))) ) (go un1) un2 (setq v (cons z2 v)) preced(cond ((null x) (go pr4)) ((lessp y (car (car x))) (go pr2))) pr1 (setq x (cons (cons y z) x)) (go next) pr2 (setq v (cons (cond ((and (eqcar (car v) (cdar x)) (flagp (cdar x) 'nary)) (cons (cdar x) (cons (cadr v) (cdar v)))) (t (cons (cdar x) (list (cadr v) (car v)))) ) (cdr (cdr v)))) (setq x (cdr x)) (go preced) stat (setq w (cons (eval (list y)) w)) (setq y nil) (go a) end1 (cond ((and (and (null v) (null w)) (null x)) (return nil)) (t (setq y 0))) (go infx) pr4 (cond ((null (equal y 0)) (go pr1)) (t (return (car v)))) )) (de eqcar (u v) (and (null (atom u)) (eq (car u) v))) (de mksetq (u v) (list 'setq u v)) (de mkvar (u v) u) (de rread nil (prog (x) (setq x (token)) (return (cond ((and (equal ttype!* 3) (eq x '!()) (rrdls)) (t x)))) ) (de rrdls nil (prog (x) (setq x (rread)) (cond ((null (equal ttype!* 3)) (go a)) ((eq x '!)) (return nil)) ((null (eq x '!.)) (go a))) (setq x (rread)) (token) (return x) a (return (cons x (rrdls)))) ) (de token nil (prog (x y) (setq x crchar!*) a (cond ((seprp x) (go sepr)) ((digit x) (go number)) ((liter x) (go letter)) ((eq x '!%) (go coment)) ((eq x '!!) (go escape)) ((eq x '!') (go quote)) ((eq x '!") (go string))) (setq ttype!* 3) (cond ((delcp x) (go d))) (setq nxtsym!* x) a1 (setq crchar!* (readch)) (go c) escape(setq y (cons x y)) (setq x (readch)) letter(setq ttype!* 0) let1 (setq y (cons x y)) (cond ((or (digit (setq x (readch))) (liter x)) (go let1)) ((eq x '!!) (go escape))) (setq nxtsym!* (intern (compress (reverse y)))) b (setq crchar!* x) c (return nxtsym!*) number(setq ttype!* 2) num1 (setq y (cons x y)) (cond ((digit (setq x (readch))) (go num1))) (setq nxtsym!* (compress (reverse y))) (go b) quote (setq crchar!* (readch)) (setq nxtsym!* (list 'quote (rread))) (setq ttype!* 4) (go c) string(prog (raise) (setq raise !*raise) (setq !*raise nil) strinx(setq y (cons x y)) (cond ((null (eq (setq x (readch)) '!")) (go strinx))) (setq y (cons x y)) (setq nxtsym!* (mkstrng (compress (reverse y)))) (setq !*raise raise)) (setq ttype!* 1) (go a1) coment(cond ((null (eq (readch) !$eol!$)) (go coment))) sepr (setq x (readch)) (go a) d (setq nxtsym!* x) (setq crchar!* '! ) (go c))) (setq crchar!* '! ) (de delcp (u) (or (eq u '!;) (eq u '!$))) (de mkstrng (u) u) (de seprp (u) (or (eq u '! ) (eq u !$eol!$))) (de scan nil (prog (x y) (cond ((null (eq cursym!* '!*semicol!*)) (go b))) a (setq nxtsym!* (token)) b (cond ((or (null (atom nxtsym!*)) (numberp nxtsym!*)) (go l)) ((and (setq x (get nxtsym!* 'newnam)) (setq nxtsym!* x)) (go b)) ((eq nxtsym!* 'comment) (go comm)) ((and (eq nxtsym!* '!') (setq cursym!* (list 'quote (rread)))) (go l1)) ((null (setq x (get nxtsym!* 'switch!*))) (go l)) ((eq (cadr x) '!*semicol!*) (return (setq cursym!* (cadr x)))) ) sw1 (setq nxtsym!* (token)) (cond ((or (null (car x)) (null (setq y (assoc nxtsym!* (car x)))) ) (return (setq cursym!* (cadr x)))) ) (setq x (cdr y)) (go sw1) comm (cond ((eq (readch) '!;) (setq crchar!* '! )) (t (go comm))) (go a) l (setq cursym!* (cond ((null (eqcar nxtsym!* 'string)) nxtsym!*) (t (cons 'quote (cdr nxtsym!*)))) ) l1 (setq nxtsym!* (token)) (return cursym!*))) (de ifstat nil (prog (condx condit) a (setq condx (xread t)) (setq condit (nconc condit (list (list condx (xread t)))) ) (cond ((null (eq cursym!* 'else)) (go b)) ((eq (scan) 'if) (go a)) (t (setq condit (nconc condit (list (list t (xread1 t)))) ))) b (return (cons 'cond condit)))) (de procstat nil (prog (x y) (cond ((eq cursym!* 'symbolic) (scan))) (cond ((eq cursym!* '!*semicol!*) (return (null (setq !*mode 'symbolic)))) ) (setq fname!* (scan)) (cond ((atom (setq x (xread1 nil))) (setq x (list x)))) (setq y (xread nil)) (cond ((flagp (car x) 'lose) (return nil))) (putd (car x) 'expr (list 'lambda (cdr x) y)) (setq fname!* nil) (return (list 'quote (car x)))) ) (de blockstat nil (prog (x hold varlis !*blockp) a0 (setq !*blockp t) (scan) (cond ((null (or (eq cursym!* 'integer) (eq cursym!* 'scalar))) (go a))) (setq x (xread nil)) (setq varlis (nconc (cond ((eqcar x '!*comma!*) (cdr x)) (t (list x))) varlis)) (go a0) a (setq hold (nconc hold (list (xread1 nil)))) (setq x cursym!*) (scan) (cond ((not (eq x 'end)) (go a))) (return (mkprog varlis hold)))) (de mkprog (u v) (cons 'prog (cons u v))) (de gostat nil (prog (x) (scan) (setq x (scan)) (scan) (return (list 'go x)))) (put 'go 'stat 'gostat) (de rlis nil (prog (x) (setq x cursym!*) (return (cond ((not (flagp (scan) 'delim)) (list x (list 'quote (list (xread1 t))))) (t (list x)))))) (rds oldchan!*)