1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771 |
- % "buildreduce.lsp" Copyright (C) Codemist 2016-2021
- %
- % Build a CSL REDUCE.
- %
- % Depending on how this file is used it will EITHER create a bootstrap
- % version of REDUCE or a full and optimised one.
- %
- % The behaviour is determined by whether the version of CSL used to
- % run it has a full complement of functions in the modules u01.c to u60.c.
- %
- %
- % bootstrapreduce -z buildreduce.lsp -D@srcdir=<DIR> -D@reduce=<DIR>
- %
- % Builds a system "bootstrapreduce.img" that does not depend on any
- % custom C code. The main use of this slow system is for profiling
- % REDUCE and then compiling the hot-spots into C. Once that has been
- % done this image is logically unnecessary.
- %
- %
- % reduce -z buildreduce.lsp -D@srcdir=<DIR> -D@reduce=<dir>
- %
- % Here the files u01.c to u60.c and u01.lsp to u60.lsp must already
- % have been created, and that the reduce executable has them compiled in.
- % The REDUCE source files that are compiled *MUST* be the same as those used
- % to create this C code.
- % Author: Anthony C. Hearn, Stanley L. Kameny and Arthur Norman
- % $Id: buildreduce.lsp 5439 2020-10-19 07:24:47Z arthurcnorman $
- (cond
- ((eq 'vsl (car lispsystem!*)) (rdf "$srcdir/vsl.lsp")))
- (verbos 3)
- (window!-heading "basic CSL")
- (make!-special '!*savedef)
- (make!-special '!*backtrace)
- % "-Dbootstrap" can force !*savedef even in an embedded world.
- (setq !*savedef (and (or (boundp 'bootstrap)
- (not (memq 'embedded lispsystem!*)))
- (zerop (cdr (assoc 'c!-code lispsystem!*)))))
- (make!-special '!*noinlines)
- (prog (w)
- (setq w (errorset 'noinlines nil nil))
- (setq !*noinlines (and (not (atom w)) (car w)))
- (print (list '!*noinlines 'set 'to !*noinlines)))
- % A command-line flag "-g" sets the variable !*backtrace and so can activate
- % this. But beware that otherwise !*backtrace may be an unset variable, and
- % so I use an errorset to protect myself.
- (prog (w)
- (setq w (errorset '!*backtrace nil nil))
- (cond
- ((or (atom w) (null (car w))) (setq !*backtrace nil))
- (t (enable!-errorset 3 3)
- (setq !*backtrace t))))
- (cond
- (!*backtrace (setq !*echo t)))
- (make!-special '!*native_code)
- (setq !*native_code nil)
- (cond ((and (null !*savedef)
- (null (memq 'jlisp lispsystem!*))
- (or (boundp 'force_c_code)
- (null (memq 'embedded lispsystem!*)))) (progn
- % This is all to do with getting stuff that was compiled into C++ hooked in
- (de c!:install (name env c!-version !&optional c1)
- (cond
- (c1 (check!-c!-code name env c!-version c1))
- (t (progn
- (put name 'c!-version c!-version)
- (cond (env (prog (v n)
- (setq v (mkvect (sub1 (length env))))
- (setq n 0)
- top (cond
- ((null env) (progn
- (put name 'funarg v)
- (return (symbol!-set!-env name v)))))
- (putv v n (car env))
- (setq n (add1 n))
- (setq env (cdr env))
- (go top))))
- name))))
- (prog (name names)
- (setq names '(
- "u01.lsp" "u02.lsp" "u03.lsp" "u04.lsp" "u05.lsp"
- "u06.lsp" "u07.lsp" "u08.lsp" "u09.lsp" "u10.lsp"
- "u11.lsp" "u12.lsp" "u13.lsp" "u14.lsp" "u15.lsp"
- "u16.lsp" "u17.lsp" "u18.lsp" "u19.lsp" "u20.lsp"
- "u21.lsp" "u22.lsp" "u23.lsp" "u24.lsp" "u25.lsp"
- "u26.lsp" "u27.lsp" "u28.lsp" "u29.lsp" "u30.lsp"
- "u31.lsp" "u32.lsp" "u33.lsp" "u34.lsp" "u35.lsp"
- "u36.lsp" "u37.lsp" "u38.lsp" "u39.lsp" "u40.lsp"
- "u41.lsp" "u42.lsp" "u43.lsp" "u44.lsp" "u45.lsp"
- "u46.lsp" "u47.lsp" "u48.lsp" "u49.lsp" "u50.lsp"
- "u51.lsp" "u52.lsp" "u53.lsp" "u54.lsp" "u55.lsp"
- "u56.lsp" "u57.lsp" "u58.lsp" "u59.lsp" "u60.lsp"))
- top(cond ((null names) (return nil)))
- (setq name (car names))
- (setq names (cdr names))
- % If I am "generic" I will find u01.lsp etc in the current directory...
- (cond
- ((or (memq 'embedded lispsystem!*)
- (not (memq 'generic lispsystem!*)))
- (setq name (compress (cons '!"
- (append (explodec "$reduce/cslbuild/generated-c/")
- (cdr (explode name))))))))
- (rdf name)
- (go top)) )))
- (fluid '(!*nocompile))
- (setq !*nocompile nil)
- (cond
- ((and (boundp 'interpreted) (eq (compress (explodec interpreted)) 'yes))
- (setq !*nocompile t)))
- (cond
- ((memq 'vsl lispsystem!*)
- (faslout 'cslcompat)
- (rdf "$srcdir/vsl.lsp")
- (faslend)
- )
- (t (rdf "$srcdir/fastgets.lsp")
- (rdf "$srcdir/compat.lsp")
- (rdf "$srcdir/extras.lsp")
- (rdf (cond
- ((memq 'jlisp lispsystem!*) "$srcdir/compiler-for-jlisp.lsp")
- (t "$srcdir/compiler.lsp")))
- (progn (terpri)
- (princ "### !*nocompile = ")
- (print !*nocompile)
- nil)
- (setq !*comp (null !*nocompile))
- % Compile some important things first to improve bootstrapping speed.
- (cond
- ((null !*nocompile)
- (compile '(
- s!:improve s!:literal_order s!:comval s!:outopcode0
- s!:plant_basic_block s!:remlose s!:islocal
- s!:is_lose_and_exit s!:comatom s!:destination_label
- s!:record_literal s!:resolve_labels s!:expand_jump
- s!:outopcode1lit stable!-sortip s!:iseasy s!:outjump
- s!:add_pending s!:comcall s!:resolve_literals))
- (compile!-all)))
- % Tidy up be deleting any modules that are left over in this image
- (dolist (a (library!-members)) (delete!-module a))
- % Build fasl files for the compatibility code and the two
- % versions of the compiler.
- (faslout 'cslcompat)
- (rdf "$srcdir/fastgets.lsp")
- (rdf "$srcdir/compat.lsp")
- (rdf "$srcdir/extras.lsp")
- (faslend)
- (faslout 'compiler)
- (rdf (cond
- ((memq 'jlisp lispsystem!*) "$srcdir/compiler-for-jlisp.lsp")
- (t "$srcdir/compiler.lsp")))
- (faslend)
- ))
- (setq !*comp (null !*nocompile))
- (de concat (u v)
- (compress (cons '!" (append (explode2 u)
- (nconc (explode2 v) (list '!"))))))
- (global '(oldchan!*))
- (setq prolog_file 'cslprolo)
- (setq rend_file 'cslrend)
- (setq !*argnochk t)
- (setq !*int nil) % Prevents input buffer being saved.
- (setq !*msg nil)
- (window!-heading "bootstrap RLISP")
- % This is dervived fron the Standard LISP BOOT File.
- % Author: Anthony C. Hearn.
- % Copyright (c) 1991 RAND. All Rights Reserved.
- (fluid '(fname!* !*blockp !*lower !*mode))
- (global '(oldchan!*))
- (fluid '(!*raise !*lower))
- (global '(crchar!* cursym!* 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 equal))
- (put '!: 'switch!* '(((!= nil setq)) !*colon!*))
- (put '!< 'switch!* '(((!= nil leq) (!< nil !*lsqbkt!*)) lessp))
- (put '!> 'switch!* '(((!= nil geq) (!> nil !*rsqbkt!*)) greaterp))
- % When the full parser is loaded the function mkprec() will reset all
- % these precedences. Until then please parenthesize expressions carefully.
- (put '!*comma!* 'infix 1)
- (put 'setq 'infix 2)
- (put 'cons 'infix 3)
- (put 'equal 'infix 4)
- (put 'eq 'infix 5)
- (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))
- ((and w (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 (car w))
- 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 rread nil
- (prog (x)
- (setq x (token))
- (return
- (cond
- ((and (equal ttype!* 3) (eq x '!()) (rrdls))
- (t x)))) )
- (de rrdls nil
- (prog (x r)
- a (setq x (rread))
- (cond
- ((null (equal ttype!* 3)) (go b))
- ((eq x '!)) (return (reverse r))) % REVERSIP not yet defined.
- ((null (eq x '!.)) (go b)))
- (setq x (rread))
- (token)
- (return (nconc (reverse r) x))
- b (setq r (cons x r))
- (go a)))
- (de token nil
- (prog (x y z)
- (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 z (cons !*raise !*lower))
- (setq !*raise (setq !*lower nil))
- (setq x (readch))
- (setq !*raise (car z))
- (setq !*lower (cdr z))
- 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 !*lower)
- (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 blank) (eq u tab) (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 (list x (list 'quote (list (xread t)))))))
- (de endstat nil (prog (x) (setq x cursym!*) (scan) (return (list x))))
- % It is only a rather small number of lines of code to support
- % both << >> blocks and WHILE statements here, and doing so makes
- % it possible to write the full implementation of RLISP in a much
- % more civilised way. What I put in here is a little more than is used
- % to start with, but matches the eventual implementation. Eg the 'go
- % and 'nodel flags are not relevant until the read parser has been loaded.
- (de readprogn nil
- (prog (lst)
- a (setq lst (cons (xread 'group) lst))
- (cond ((null (eq cursym!* '!*rsqbkt!*)) (go a)))
- (scan)
- (return (cons 'progn (reverse lst)))))
- (put '!*lsqbkt!* 'stat 'readprogn)
- (flag '(!*lsqbkt!*) 'go)
- (flag '(!*rsqbkt!*) 'delim)
- (flag '(!*rsqbkt!*) 'nodel)
- (de whilstat ()
- (prog (!*blockp bool bool2)
- (cond
- ((flagp 'do 'delim) (setq bool2 t))
- (t (flag '(do) 'delim)))
- (setq bool (xread t))
- (cond
- (bool2 (remflag '(do) 'delim)))
- (cond
- ((not (eq cursym!* 'do)) (symerr 'while t)))
- (return (list 'while bool (xread t)))))
- (dm while (u)
- (prog (body bool lab)
- (setq bool (cadr u))
- (setq body (caddr u))
- (setq lab 'whilelabel)
- (return (list
- 'prog nil
- lab (list 'cond
- (list (list 'not bool) '(return nil)))
- body
- (list 'go lab)))))
- (put 'while 'stat 'whilstat)
- (flag '(while) 'nochange)
- (de repeatstat ()
- (prog (!*blockp body bool)
- (cond
- ((flagp 'until 'delim) (setq bool t))
- (t (flag '(until) 'delim)))
- (setq body (xread t))
- (cond
- ((null bool) (remflag '(until) 'delim)))
- (cond
- ((not (eq cursym!* 'until)) (symerr 'repeat t)))
- (return (list 'repeat body (xread t)))))
- (dm repeat (u)
- (progn (terpri) (print (prog (body bool lab)
- (setq body (cadr u))
- (setq bool (caddr u))
- (setq lab 'repeatlabel)
- (return (list
- 'prog nil
- lab body
- (list 'cond
- (list (list 'not bool) (list 'go lab))))))))))
- (put 'repeat 'stat 'repeatstat)
- (flag '(repeat) 'nochange)
- % Now we have just enough to be able to start to express ourselves in
- % (a subset of) rlisp.
- (begin2)
- rds(xxx := open("$reduce/packages/support/build.red", 'input));
- (close xxx)
- (load!-package!-sources prolog_file 'support)
- (load!-package!-sources 'revision 'support)
- (cond (!*backtrace (setq !*echo t)))
- (load!-package!-sources 'rlisp 'rlisp)
- (load!-package!-sources 'smacros 'support)
- (load!-package!-sources rend_file 'support)
- (load!-package!-sources 'poly 'poly)
- (load!-package!-sources 'alg 'alg)
- (load!-package!-sources 'arith 'arith) % Needed by roots, specfn*, (psl).
- (load!-package!-sources 'entry 'support)
- (load!-package!-sources 'remake 'support)
- (setq !*comp nil)
- (begin)
- symbolic;
- !#if (and (or (boundp 'force_c_code) (not (memq 'embedded lispsystem!*)))
- (not !*savedef))
- faslout 'user;
- %
- % The "user" module is only useful when building a full system, since
- % in the bootstrap the files u01.lsp to u60.lsp will probably not exist
- % and it is CERTAIN that they are not useful.
- %
- if modulep 'cslcompat then load!-module 'cslcompat;
- !#if (not (memq 'jlisp lispsystem!*))
- % Note that Jlisp will use a different scheme to get the literal-vectors
- % of translated functions installed.
- symbolic procedure c!:install(name, env, c!-version, !&optional, c1);
- begin
- scalar v, n;
- if c1 then return check!-c!-code(name, env, c!-version, c1);
- put(name, 'c!-version, c!-version);
- if null env then return name;
- v := mkvect sub1 length env;
- n := 0;
- while env do <<
- putv(v, n, car env);
- n := n + 1;
- env := cdr env >>;
- % I only instate the environment if there is nothing useful there at
- % present. This is a rather dubious test!
- if symbol!-env name = nil or
- symbol!-env name = name then symbol!-set!-env(name, v);
- put(name, 'funarg, v);
- return name;
- end;
- for each name in '(
- "u01.lsp" "u02.lsp" "u03.lsp" "u04.lsp" "u05.lsp"
- "u06.lsp" "u07.lsp" "u08.lsp" "u09.lsp" "u10.lsp"
- "u11.lsp" "u12.lsp" "u13.lsp" "u14.lsp" "u15.lsp"
- "u16.lsp" "u17.lsp" "u18.lsp" "u19.lsp" "u20.lsp"
- "u21.lsp" "u22.lsp" "u23.lsp" "u24.lsp" "u25.lsp"
- "u26.lsp" "u27.lsp" "u28.lsp" "u29.lsp" "u30.lsp"
- "u31.lsp" "u32.lsp" "u33.lsp" "u34.lsp" "u35.lsp"
- "u36.lsp" "u37.lsp" "u38.lsp" "u39.lsp" "u40.lsp"
- "u41.lsp" "u42.lsp" "u43.lsp" "u44.lsp" "u45.lsp"
- "u46.lsp" "u47.lsp" "u48.lsp" "u49.lsp" "u50.lsp"
- "u51.lsp" "u52.lsp" "u53.lsp" "u54.lsp" "u55.lsp"
- "u56.lsp" "u57.lsp" "u58.lsp" "u59.lsp" "u60.lsp") do <<
- if memq('embedded, lispsystem!*) or
- not memq('generic, lispsystem!*) then
- name := compress('!" .
- append(explodec "$reduce/cslbuild/generated-c/",
- cdr explode name));
- rdf name >>;
- !#endif % jlisp
- if modulep 'smacros then load!-module 'smacros;
- faslend;
- !#endif % embedded
- faslout 'xremake;
- fluid '(!*nocompile);
- !*nocompile := nil;
- if boundp 'interpreted and eq(compress explodec interpreted, 'yes) then
- !*nocompile := t;
- !#if (and (or (boundp 'force_c_code) (not (memq 'embedded lispsystem!*)))
- (not !*savedef))
- load!-module "user";
- !#endif % embedded
- in "$reduce/packages/support/remake.red"$
- global '(reduce_base_modules reduce_extra_modules
- reduce_test_cases reduce_regression_tests
- !*reduce!-packages!*);
- symbolic procedure get_configuration_data();
- % Read data from a configuration file that lists the modules that must
- % be processed. NOTE that this and the next few funtions will ONLY
- % work properly if REDUCE had been started up with the correct
- % working directory. This is (just about) acceptable because these are
- % system maintainance functions rather than generally flexible things
- % for arbitrary use.
- begin
- scalar i, w, e, r, r1;
- % Configuration information is held in a file called something like
- % "package.map".
- if (boundp 'minireduce and symbol!-value 'minireduce) or
- memq('vsl, lispsystem!*) then i := "package.map"
- else i := "$reduce/packages/package.map";
- i := open(i, 'input);
- i := rds i;
- e := !*echo;
- !*echo := nil;
- w := read();
- !*echo := e;
- i := rds i;
- close i;
- reduce_base_modules :=
- for each x in w conc
- if member('core, cddr x) and
- member('csl, cddr x) then list car x else nil;
- reduce_extra_modules :=
- for each x in w conc
- if not member('core, cddr x) and
- member('csl, cddr x) then list car x else nil;
- reduce_test_cases :=
- for each x in w conc
- if member('test, cddr x) and
- member('csl, cddr x) then list car x else nil;
- % Any file with a name *.tst in the regressions directory will be
- % considered to be a test case in addition to ones explicitly shown
- % in package.map.
- reduce_regression_tests := nil;
- % The embedded build may not support the list!-directory function and so
- % I arrange that if it fails I just omit being aware of the regression
- % test scripts. Soon the embedded system (built ising C++17) will in fact
- % support this!
- if memq('embedded, lispsystem!*) then rdf("$srcdir/regressions.list")
- else <<
- r := errorset(list('list!-directory, "$reduce/packages/regressions"),
- nil, nil);
- if atom r then r :=nil else r := car r;
- for each f in r do <<
- r1 := reverse explodec f;
- if eqcar(r1, 't) and
- eqcar(cdr r1, 's) and
- eqcar(cddr r1, 't) and
- eqcar(cdddr r1, '!.) then <<
- r1 := intern list!-to!-string reverse cddddr r1;
- put(r1, 'folder, "regressions");
- reduce_regression_tests :=
- r1 . reduce_regression_tests >> >> >>;
- % I will run the "alg" test twice! This is for the benefit of Java where the
- % first time will be seriously slowed down by the need to JIT almost
- % everything.
- reduce_test_cases := 'alg . append(reduce_test_cases, reduce_regression_tests);
- for each x in w do
- if member('csl, cddr x) then put(car x, 'folder, cadr x);
- % princ "reduce_base_modules: "; print reduce_base_modules;
- % princ "reduce_extra_modules: "; print reduce_extra_modules;
- % princ "reduce_test_cases: "; print reduce_test_cases;
- % princ "reduce_regression_tests: "; print reduce_regression_tests;
- !*reduce!-packages!* := append(reduce_base_modules, reduce_extra_modules);
- return;
- end;
- symbolic procedure build_reduce_modules names;
- begin
- scalar w;
- if boundp 'interpreted and interpreted then !*nocompile := t;
- !*comp := null !*nocompile;
- !#if !*savedef
- !*savedef := t;
- !#else
- !*savedef := nil;
- !#endif
- !#if !*noinlines
- !*noinlines := t;
- !#else
- !*noinlines := nil;
- !#endif
- make!-special '!*native_code;
- !*native_code := nil;
- get_configuration_data();
- if !*backtrace then !*echo := t; % To help with debugging...
- w := explodec car names;
- if !*savedef then w := append(explodec "[Bootstrap] ", w);
- window!-heading list!-to!-string w;
- !#if !*savedef
- % When building the bootstrap version I want to record what switches
- % get declared...
- if not getd 'original!-switch then <<
- w := getd 'switch;
- putd('original!-switch, car w, cdr w);
- putd('switch, 'expr,
- '(lambda (x)
- (dolist (y x) (princ "+++ Declaring a switch: ") (print y))
- (original!-switch x))) >>;
- !#endif
- package!-remake car names;
- if null (names := cdr names) then <<
- printc "Recompilation complete";
- window!-heading "Recompilation complete" >>;
- !#if (or !*savedef
- (and (not (boundp 'force_c_code)) (memq 'embedded lispsystem!*)))
- if null names then restart!-csl 'begin
- else restart!-csl('(xremake build_reduce_modules), names)
- !#else
- if null names then restart!-csl '(user begin)
- else restart!-csl('(xremake build_reduce_modules), names)
- !#endif
- end;
- fluid '(cpulimit conslimit testdirectory);
- symbolic procedure test_a_package names;
- begin
- scalar packge, logname, logtmp, logfile;
- scalar quitfn, oll, rr, !*redefmsg, !*redeflg!*, walltime, w;
- if not boundp 'cpulimit or
- not fixp (cpulimit := compress explodec cpulimit) or
- cpulimit < 1 then
- cpulimit := if memq('jlisp, lispsystem!*) then 6000 else 360;
- if not boundp 'conslimit or
- not fixp (conslimit := compress explodec conslimit) or
- conslimit < 1 then
- conslimit := 2000;
- princ "TESTING: "; printc car names;
- window!-heading list!-to!-string append(explodec "[Testing] ",
- explodec car names);
- !*backtrace := nil;
- !*errcont := t;
- !*extraecho := t; % Ensure standard environment for the test...
- !*int := nil; % ... so that results are predictable.
- packge := car names;
- verbos nil;
- % Normally logs from testing go in testlogs/name.rlg, however you may
- % may sometimes want to put them somewhere else. If you do then launch reduce
- % along the lines
- % reduce -D@log="mylogs" ...
- % and ensure that <top>/mylogs exists.
- if boundp '!@log and stringp symbol!-value '!@log then
- logname := symbol!-value '!@log
- else logname := "testlogs";
- logname := concat(logname, "/");
- logtmp := concat(logname, concat(car names, ".tmp"));
- logname := concat(logname, concat(car names,".rlg"));
- logfile := open(logtmp, 'output);
- get_configuration_data();
- % Any messages generated while loading the package do NOT appear in the log
- if not memq(packge, reduce_regression_tests) then load!-package packge;
- begin
- scalar !*terminal!-io!*, !*standard!-output!*, !*error!-output!*,
- !*trace!-output!*, !*debug!-io!*, !*query!-io!*, !*errcont,
- outputhandler!*;
- !*terminal!-io!* := !*standard!-output!* := !*error!-output!* := logfile;
- !*trace!-output!* := !*debug!-io!* := !*query!-io!* := logfile;
- oll := linelength 80;
- % princ date(); princ " run on "; printc cdr assoc('name, lispsystem!*);
- if get(packge,'folder) then packge := get(packge,'folder);
- testdirectory := concat("$reduce/packages/", packge);
- packge := concat("$reduce/packages/",
- concat(packge,
- concat("/",
- concat(car names,".tst"))));
- quitfn := getd 'quit;
- % At least at one stage at least one test file ends in "quit;" rather than
- % "end;" and the normal effect would be that this leads it to cancel
- % all execution instantly. To avoid that I will undefine the function
- % "quit", but restore it after the test. I reset !*redefmsg to avoid getting
- % messages about this. I redefined quit to something (specifically "posn")
- % that does not need an argument and that is "harmless".
- remd 'quit;
- putd('quit, 'expr, 'posn);
- !*mode := 'algebraic;
- !*extraecho := t; % Ensure standard environment for the test...
- !*int := nil; % ... so that results are predictable.
- !*errcont := t;
- % resource!-limit is a special feature in CSL so that potentially wild
- % code can be run with it being stopped harshly if it gets stuck.
- % The first argument is an expression to evaluate. The next 4 are
- % a time limit, in seconds
- % a "cons" limit, in megaconses
- % a limit on the number of thousands of I/O bytes that can be
- % performed, with both reading and printing counted
- % a limit on the number of Lisp-level errors that can be raised.
- % note that that can be large if errorset is used to trap them.
- %
- % If a limit is specified as a negative value (typically -1) then that
- % resource is not applied.
- % The first 3 limits are applied in an APPROXIMATE way, and the first
- % is seriously sensitive the the speed of the computer you are running
- % on, so should be used with real care. At the end the return value
- % is atomic if a limit expired, otherwise ncons of the regular value.
- % A global variable *resources* should end up a list of 4 values
- % showing the usage in each category.
- % The settings here are intended to be fairly conservative...
- % Time: On an Intel Q6600 CPU the longest test runs in under 20 seconds,
- % so allowing 3 minutes gives almost a factor of 10 slack. If
- % many people are running slow(ish) machines still I can increase
- % the limit.
- % Space: The amount of space used ought to be pretty independent of
- % the computer used. Measuring on 32 and 64-bit systems will
- % give minor differences. But the limit given here seems to allow
- % all the current tests to run with a factor of 2 headroom
- % in case the test-scripts are updated.
- % IO: The "crack" package has code in it that checkpoints its state
- % to disc periodically, and tests that activate that use amazingly
- % more IO than the others. The limit at 10 Mbytes suits the
- % relevant current tests. If a broken package leads to a test
- % script looping this then means that the resulting log file is no
- % larger than (about) 10 Mbytes, which is ugly but managable.
- % Errors: Some REDUCE packages make extensive use of errorset and
- % predictable use of "error" (for lack of use of catch and throw,
- % usually). So I do not constrain errors here. But if things were
- % ever such that no errors were expected I could enforce that
- % condition here.
- walltime := timeofday();
- eval '(resettime1);
- rr := resource!-limit(list('in_list1, mkquote packge, t),
- cpulimit, % CPU time per test
- conslimit, % megaconses
- 10000,% allow ten megabytes of I/O
- -1); % Do not limit Lisp-level errors at all
- erfg!* := nil;
- terpri();
- princ "Tested on ";
- princ cdr assoc('platform, lispsystem!*);
- princ " CSL";
- eval '(showtime1 nil);
- w := timeofday();
- walltime := (car w - car walltime) . (cdr w - cdr walltime);
- w := cdr walltime;
- walltime := car walltime;
- if w < 0 then << walltime := walltime - 1; w := w + 1000000 >>;
- princ "real ";
- princ (walltime/60);
- princ "m";
- princ remainder(walltime, 60);
- princ ".";
- % This illustrates that I need a proper general formatted print mechanism!
- w := (w + 500)/1000;
- if w < 10 then princ "00"
- else if w < 100 then princ "0";
- princ w;
- printc "s";
- erfg!* := nil;
- putd('quit, car quitfn, cdr quitfn);
- if atom rr then printc "+++++ Error: Resource limit exceeded";
- linelength oll
- end;
- close logfile;
- delete!-file logname;
- rename!-file(logtmp, logname);
- names := cdr names;
- if null names then <<
- printc "Testing complete";
- window!-heading "Testing complete";
- restart!-csl t >>
- else restart!-csl('(xremake test_a_package), names)
- end;
- symbolic procedure profile_compare_fn(p, q);
- begin
- scalar a, b;
- a := (float caddr p/float cadr p);
- b := (float caddr q/float cadr q);
- if a < b then return t
- else if a > b then return nil
- else return ordp(p, q) % Use alpha ordering on function
- % if counts match exactly.
- end;
- %
- % This function runs a test file and sorts out what the top 350
- % functions in it. It appends their names to "profile.dat".
- %
- symbolic procedure profile_a_package names;
- begin
- scalar packge, oll, w, w1, w2, quitfn, !*errcont, rr;
- if not boundp 'cpulimit or
- not fixp (cpulimit := compress explodec cpulimit) or
- cpulimit < 1 then
- cpulimit := if memq('jlisp, lispsystem!*) then 5000 else 180;
- if not boundp 'conslimit or
- not fixp (conslimit := compress explodec conslimit) or
- conslimit < 1 then
- conslimit := 2000;
- princ "PROFILING: "; print car names;
- !*backtrace := nil;
- !*errcont := t;
- !*int := nil;
- packge := car names;
- verbos nil;
- get_configuration_data();
- if not memq(packge, reduce_regression_tests) then <<
- load!-package packge;
- if get(packge,'folder) then packge := get(packge,'folder);
- testdirectory := concat("$reduce/packages/", packge);
- packge := concat("$reduce/packages/",
- concat(packge,
- concat("/",
- concat(car names,".tst"))));
- oll := linelength 80;
- !*mode := 'algebraic;
- window!-heading list!-to!-string append(explodec "[Profile] ",
- explodec car names);
- quitfn := getd 'quit;
- remd 'quit;
- putd('quit, 'expr, 'posn);
- mapstore 4; % reset counts;
- !*errcont := t;
- % I try hard to arrange that even if the test fails I can continue and that
- % input & output file selection is not messed up for me.
- w := wrs nil; w1 := rds nil;
- wrs w; rds w1;
- rr := resource!-limit(list('errorset,
- mkquote list('in_list1, mkquote packge, t),
- nil, nil),
- cpulimit,
- conslimit,
- 10000,% allow ten megabytes of I/O
- -1); % Do not limit Lisp-level errors at all
- wrs w; rds w1;
- erfg!* := nil;
- terpri();
- putd('quit, car quitfn, cdr quitfn);
- w := sort(mapstore 2, function profile_compare_fn);
- begin
- scalar oo;
- oo := wrs open("buildlogs/flaguse.log", 'append);
- bytecounts t;
- close wrs oo;
- end;
- load!-source(); % Need source versions of all code here
- w1 := nil;
- while w do <<
- w2 := get(caar w, '!*savedef);
- if eqcar(w2, 'lambda) then w1 := (caar w . md60 (caar w . cdr w2) .
- cadar w . caddar w) . w1;
- w := cdr w >>;
- w := w1;
- % I collect the top 350 functions as used by each test, not because all
- % that many will be wanted but because I might as well record plenty
- % of information here and discard unwanted parts later on.
- for i := 1:349 do if w1 then w1 := cdr w1;
- if w1 then rplacd(w1, nil);
- % princ "MODULE "; prin car names; princ " suggests ";
- % print for each z in w collect car z;
- w1 := open("profile.dat", 'append);
- w1 := wrs w1;
- linelength 80;
- if atom rr then printc "% +++++ Error: Resource limit exceeded";
- princ "% @@@@@ Resources used: "; print !*resources!*;
- princ "("; prin car names; terpri();
- for each n in w do <<
- princ " ("; prin car n; princ " ";
- if posn() > 30 then << terpri(); ttab 30 >>;
- prin cadr n;
- % I also display the counts just to help me debug & for interest.
- princ " "; prin caddr n; princ " "; princ cdddr n;
- printc ")" >>;
- printc " )";
- terpri();
- close wrs w1;
- linelength oll >>;
- names := cdr names;
- if null names then <<
- w1 := open("buildlogs/flaguse.log", 'input);
- w1 := rds w1;
- w := nil;
- while (w2 := read()) neq !$eof!$ do
- w := sort(w2, 'orderp) . w;
- close rds w1;
- rr := '((symbol!-make!-fastget 'lose 1)
- (symbol!-make!-fastget 'noncom 0));
- flag('(lose noncom), 'processed);
- oll := 2;
- while w do <<
- w1 := nil;
- for each x in w do <<
- if x and
- not flagp(cadar x, 'processed) and
- oll < 63 then <<
- rr :=
- list('symbol!-make!-fastget, mkquote cadar x, oll) . rr;
- flag(list cadar x, 'processed);
- oll := oll + 1 >>;
- if cdr x then w1 := cdr x . w1 >>;
- w := reverse w1 >>;
- w := open("buildlogs/fastgets.lsp", 'output);
- w := wrs w;
- printc "% fastgets.lsp generated by profiling";
- terpri();
- prettyprint ('progn . reverse rr);
- terpri();
- printc "% end of fastgets.lsp";
- close wrs w;
- printc "Profiling complete";
- window!-heading "Profiling complete";
- restart!-csl t >>
- else restart!-csl('(xremake profile_a_package), names)
- end;
- symbolic procedure trim_prefix(a, b);
- begin
- while a and b and car a = car b do <<
- a := cdr a;
- b := cdr b >>;
- if null a then return b
- else return nil
- end;
- fluid '(time_info);
- symbolic procedure read_file f1;
- begin
- % I take the view that I can afford to read the whole of a file into
- % memory at the start of processing. This makes life easier for me
- % and the REDUCE log files are small compared with current main memory sizes.
- scalar r, w, w1, n, x;
- scalar p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13;
- % To make comparisons between my CSL logs and some of the "reference
- % logs", which are created using a different script, I will discard
- % lines that match certain patterns! Note that if the reference logs change
- % the particular tests I perform here could become out of date! Also if any
- % legitimate test output happened to match one of the following strings
- % I would lose out slightly.
- p1 := explodec "Time: ";
- p2 := explodec "user ";
- p3 := explodec "sys ";
- p4 := explodec "time to formulate conditions:";
- p5 := explodec "CRACK needed :";
- p6 := explodec "time for initializations:";
- p7 := explodec "Tested on ";
- p8 := explodec "Total time taken:";
- p9 := explodec "*** turned off switch";
- p10 := explodec "+++ levelt compiled";
- p11 := explodec "Request to set constant bitsperword";
- p12 := explodec "*** (levelt): base";
- p13 := explodec "max_gc_int :";
- r := nil;
- n := 0;
- while not ((w := readline f1) = !$eof!$) do <<
- w1 := explodec w;
- if trim_prefix(p1, w1)
- or trim_prefix(p2, w1)
- or trim_prefix(p3, w1)
- or trim_prefix(p4, w1)
- or trim_prefix(p5, w1)
- or trim_prefix(p6, w1)
- or trim_prefix(p7, w1)
- or trim_prefix(p8, w1)
- or trim_prefix(p9, w1)
- or trim_prefix(p10, w1)
- or trim_prefix(p11, w1)
- or trim_prefix(p12, w1)
- or trim_prefix(p13, w1)
- then n := n + 1
- else r := ((n := n + 1) . w) . r >>;
- w := r;
- % The text scanned for here is expected to match that generated by the
- % test script. I locate the last match in a file, extract the numbers
- % and eventually write them to testlogs/times.log
- n := explodec "Time (counter 1):";
- while w and null (x := trim_prefix(n, explodec cdar w)) do w := cdr w;
- if null w then <<
- time_info := nil;
- return reversip r >>;
- % Remove time info from lines
- w := cdr w;
- if (trim_prefix(explodec "Tested on ", explodec cdar w)) then w := cdr w;
- r := w;
- while eqcar(x, '! ) do x := cdr x;
- w := n := nil;
- while digit car x do << w := car x . w; x := cdr x >>;
- while eqcar(x, '! ) do x := cdr x;
- if x := trim_prefix(explodec "ms plus GC time:", x) then <<
- while eqcar(x, '! ) do x := cdr x;
- while digit car x do << n := car x . n; x := cdr x >> >>;
- if null w then w := '(!0);
- if null n then n := '(!0);
- time_info := compress reverse w . compress reverse n;
- return reversip r;
- end;
- fluid '(!*insist_on_exact_match);
- !*insist_on_exact_match := t;
- symbolic procedure roughly_equal(a, b);
- begin
- % a and b are strings repesenting lines of text. I want to test if they
- % match subject to some floating point slop.
- scalar wa, wb, adot, bdot;
- if a = b then return t;
- a := explodec a;
- b := explodec b;
- if !*insist_on_exact_match then return (a = b);
- top:
- % First deal with end of line matters.
- if null a and null b then return t
- else if null a or null b then return nil;
- % next split off any bits of a and b up to a digit
- wa := wb := nil;
- while a and not digit car a do <<
- wa := car a . wa;
- a := cdr a >>;
- while b and not digit car b do <<
- wb := car b . wb;
- b := cdr b >>;
- if not (wa = wb) then return nil;
- % now both a and b start with digits. I will seek a chunk of the
- % form nnn.mmmE+xxx where E<sign>xxx is optional...
- % Note that any leading sign on the float has been checked already!
- wa := wb := nil;
- adot := bdot := nil;
- while a and digit car a do <<
- wa := car a . wa;
- a := cdr a >>;
- if eqcar(a, '!.) then <<
- adot := t;
- wa := car a . wa;
- a := cdr a >>;
- while a and digit car a do <<
- wa := car a . wa;
- a := cdr a >>;
- if eqcar(a, '!e) or eqcar(a, '!E) then <<
- adot := t;
- wa := car a . wa;
- a := cdr a;
- if eqcar(a, '!+) or eqcar(a, '!-) then <<
- wa := car a . wa;
- a := cdr a >>;
- while a and digit car a do <<
- wa := car a . wa;
- a := cdr a >> >>;
- % Now all the same to grab a float from b
- while b and digit car b do <<
- wb := car b . wb;
- b := cdr b >>;
- if eqcar(b, '!.) then <<
- bdot := t;
- wb := car b . wb;
- b := cdr b >>;
- while b and digit car b do <<
- wb := car b . wb;
- b := cdr b >>;
- if eqcar(b, '!e) or eqcar(b, '!E) then <<
- bdot := t;
- wb := car b . wb;
- b := cdr b;
- if eqcar(b, '!+) or eqcar(b, '!-) then <<
- wb := car b . wb;
- b := cdr b >>;
- while b and digit car b do <<
- wb := car b . wb;
- b := cdr b >> >>;
- % Now one possibility is that I had an integer not a float,
- % and in that case I want an exact match
- if not adot or not bdot then <<
- if wa = wb then goto top
- else return nil >>;
- if wa = wb then goto top; % textual match on floating point values
- wa := compress reversip wa;
- wb := compress reversip wb;
- if fixp wa then wa := float wa;
- if fixp wb then wb := float wb;
- if not (floatp wa and floatp wb) then return nil; % messed up somehow!
- if wa = wb then goto top;
- % now the crucial approximate floating point test - note that both numbers
- % are positive, but that they may be extreme in range.
- % As a cop-out I am going to insist that if values are either very very big
- % or very very small that they match as text.
- if wa > 1.0e100 or wb > 1.0e100 then return nil;
- if wa < 1.0e-100 or wb < 1.0e-100 then return nil;
- wa := (wa - wb)/(wa + wb);
- if wa < 0 then wa := -wa;
- if wa > 0.0001 then return nil; % pretty crude!
- goto top
- end;
- symbolic procedure in_sync(d1, n1, d2, n2);
- begin
- for i := 1:n1 do if d1 then << % skip n1 lines from d1
- d1 := cdr d1 >>;
- for i := 1:n2 do if d2 then << % skip n2 lines from d2
- d2 := cdr d2 >>;
- % If one is ended but the other is not then we do not have a match. If
- % both are ended we do have one.
- if null d1 then return null d2
- else if null d2 then return nil;
- % Here I insist on 3 lines that agree before I count a match as
- % having been re-established.
- if not roughly_equal(cdar d1, cdar d2) then return nil;
- d1 := cdr d1; d2 := cdr d2;
- if null d1 then return null d2
- else if null d2 then return nil;
- if not roughly_equal(cdar d1, cdar d2) then return nil;
- d1 := cdr d1; d2 := cdr d2;
- if null d1 then return null d2
- else if null d2 then return nil;
- if not roughly_equal(cdar d1, cdar d2) then return nil;
- d1 := cdr d1; d2 := cdr d2;
- if null d1 then return null d2
- else if null d2 then return nil
- else return t
- end;
- fluid '(time_data time_ratio gc_time_ratio log_count);
- symbolic procedure prinright(x, w);
- begin
- scalar xx, xl;
- xx := explodec x;
- xl := length xx;
- while w > xl do << princ " "; xl := xl + 1 >>;
- princ x;
- end;
- fluid '(files_with_differences);
- symbolic procedure file_compare(f1, f2, name);
- begin
- scalar i, j, d1, d2, t1, gt1, t2, gt2, time_info, fdiffer;
- d1 := read_file f1;
- if null time_info then t1 := gt1 := 0
- else << t1 := car time_info; gt1 := cdr time_info >>;
- d2 := read_file f2;
- if null time_info then t2 := gt2 := 0
- else << t2 := car time_info; gt2 := cdr time_info >>;
- i := wrs time_data;
- j := set!-print!-precision 3;
- prin name;
- ttab 17;
- if zerop t1 then princ " ---"
- else << prinright(t1, 8);
- % Tag the time with an asterisk if it will not participate in the
- % eventual overall timing report.
- if t1<=200 then princ "*";
- ttab 30; prinright(gt1, 8) >>;
- ttab 40;
- if zerop t2 then princ " ---"
- else << prinright(t2, 9);
- if t2<=200 then princ "*";
- ttab 50; prinright(gt2, 8) >>;
- ttab 60;
- if zerop t1 or zerop t2 then princ " *** ***"
- else begin
- scalar r1, gr1, w;
- r1 := float t1 / float t2;
- gr1 := float (t1+gt1)/float (t2+gt2);
- % I will only use tests where the time taken was over 200ms in my eventual
- % composite summary of timings, since measurement accuracy can leave the
- % really short tests pretty meaningless.
- if t1 > 200 and t2 > 200 then <<
- % But I will go further than that and give less weight to any test whose time
- % is under 1 second, so that the cut-off is gradual rather than abrupt.
- w := min(t1, t2);
- % This means that if w (the smaller time) = 200 then then
- % the test does not contribute to the average, while if w>=1000
- % it contributes fully.
- if w < 1000.0 then w := (w - 200.0)/800.0
- else w := 1.0;
- time_ratio := time_ratio * expt(r1, w);
- gc_time_ratio := gc_time_ratio * expt(gr1, w);
- log_count := log_count + w >>;
- princ r1;
- ttab 70;
- princ gr1;
- end;
- terpri();
- set!-print!-precision j;
- wrs i;
- % The next segment of code is a version of "diff" to report ways in which
- % reference and recent log files match or diverge.
- % I can not see a neat way to get a "structured" control structure
- % here easily. Ah well, drop back to GOTO statements!
- top:
- if null d1 then << % end of one file
- if d2 then terpri();
- i := 0;
- while d2 and i < 20 do <<
- fdiffer := t;
- princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2;
- d2 := cdr d2;
- i := i + 1 >>;
- if d2 then printc "...";
- if fdiffer then files_with_differences := name . files_with_differences;
- return >>;
- if null d2 then << % end of other file
- i := 0;
- while d1 and i < 20 do <<
- fdiffer := t;
- princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1;
- d1 := cdr d1;
- i := i + 1 >>;
- if d1 then printc "...";
- if fdiffer then files_with_differences := name . files_with_differences;
- return >>;
- % The test "roughly_equal" compares allowing some tolerance on floating
- % point values. This is because REDUCE uses platform libraries for
- % floating point elementary functions and printing, so small differences
- % are expected. This is perhaps uncomfortable, but is part of reality, and
- % the test here makes comparison output much more useful in that the
- % differences shown up are better limited towards "real" ones.
- if roughly_equal(cdar d1, cdar d2) then <<
- d1 := cdr d1;
- d2 := cdr d2;
- go to top >>;
- % I will first see if there are just a few blank lines inserted into
- % one or other file. This special case is addressed here because it
- % appears more common a possibility than I had expected.
- if cdar d1 = "" and cdr d1 and roughly_equal(cdadr d1, cdar d2) then <<
- fdiffer := t;
- princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1;
- d1 := cdr d1;
- go to top >>
- else if cdar d1 = "" and cdr d1 and cdadr d1 = "" and cddr d1 and
- roughly_equal(cdaddr d1, cdar d2) then <<
- fdiffer := t;
- princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1;
- d1 := cdr d1;
- princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1;
- d1 := cdr d1;
- go to top >>
- else if cdar d2 = "" and cdr d2 and
- roughly_equal(cdadr d2, cdar d1) then <<
- fdiffer := t;
- princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2;
- d2 := cdr d2;
- go to top >>
- else if cdar d2 = "" and cdr d2 and cdadr d2 = "" and cddr d2 and
- roughly_equal(cdaddr d2, cdar d1) then <<
- fdiffer := t;
- princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2;
- d2 := cdr d2;
- princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2;
- d2 := cdr d2;
- go to top >>;
- i := 1;
- seek_rematch:
- j := 0;
- inner:
- if in_sync(d1, i, d2, j) then <<
- terpri();
- for k := 1:i do <<
- if not trim_prefix(explodec "Time (counter 1)", explodec cdar d1) and
- not trim_prefix(explodec "real ", explodec cdar d1) then
- fdiffer := t;
- princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1;
- d1 := cdr d1 >>;
- for k := 1:j do <<
- if not trim_prefix(explodec "Time (counter 1)", explodec cdar d2) and
- not trim_prefix(explodec "real ", explodec cdar d2) then
- fdiffer := t;
- princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2;
- d2 := cdr d2 >>;
- if null d1 then <<
- if fdiffer then files_with_differences := name . files_with_differences;
- return >>
- else go to top >>;
- j := j + 1;
- i := i - 1;
- if i >= 0 then go to inner;
- i := j;
- % I am prepared to seek 80 lines ahead on each side before I give up.
- % The number 80 is pretty much arbitrary.
- if i < 80 then goto seek_rematch;
- terpri();
- i := 0;
- while d2 and i < 20 do <<
- fdiffer := t;
- princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2;
- d2 := cdr d2;
- i := i+1 >>;
- if d2 then printc "...";
- i := 0;
- while d1 and i < 20 do <<
- fdiffer := t;
- princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1;
- d1 := cdr d1;
- i := i+1 >>;
- if d1 then printc "...";
- printc "Comparison failed.";
- if fdiffer then files_with_differences := name . files_with_differences;
- end;
- fluid '(which_module);
- symbolic procedure check_a_package;
- begin
- scalar oll, names, p1, logname, mylogname, mylog, reflogname, reflog,
- time_data, time_ratio, gc_time_ratio, log_count,
- files_with_differences;
- get_configuration_data();
- if boundp 'which_module and symbol!-value 'which_module and
- not (symbol!-value 'which_module = "") then <<
- names := compress explodec symbol!-value 'which_module;
- if member(names, reduce_test_cases) then names := list names
- else error(0, list("unknown module to check", which_module)) >>
- else names := reduce_test_cases;
- % I write a summary of timing information into csllogs/times.log
- time_data := open("testlogs/times.log", 'output);
- p1 := wrs time_data;
- princ "MODULE";
- ttab 21; princ "Local"; ttab 32; princ "(GC)";
- ttab 40; princ "Reference"; ttab 52; princ "(GC)";
- ttab 55; princ "Ratio"; ttab 65; printc "inc GC";
- wrs p1;
- terpri();
- oll := linelength 100;
- printc "=== Comparison results ===";
- time_ratio := gc_time_ratio := 1.0; log_count := 0.0;
- for each packge in names do <<
- terpri();
- princ "CHECKING: "; print packge;
- if boundp '!@log and stringp symbol!-value '!@log then
- logname := symbol!-value '!@log
- else logname := "testlogs";
- mylogname := concat(logname, concat("/", concat(packge, ".rlg")));
- if get(packge,'folder) then p1 := get(packge,'folder)
- else p1 := packge;
- reflogname := concat("$reduce/packages/",
- concat(p1,
- concat("/",
- concat(packge,".rlg"))));
- mylog := errorset(list('open, mkquote mylogname, ''input), nil, nil);
- reflog := errorset(list('open, mkquote reflogname, ''input), nil, nil);
- if errorp mylog then <<
- if not errorp reflog then close car reflog;
- princ "No current log in "; print mylogname >>
- else if errorp reflog then <<
- close car mylog;
- princ "No reference log in "; print reflogname >>
- else <<
- princ "LOGS: "; princ mylogname; princ " "; printc reflogname;
- mylog := car mylog; reflog := car reflog;
- file_compare(mylog, reflog, packge);
- close mylog;
- close reflog >> >>;
- time_data := wrs time_data;
- if not zerop log_count then <<
- time_ratio := expt(time_ratio, 1.0/log_count);
- gc_time_ratio := expt(gc_time_ratio, 1.0/log_count);
- terpri();
- p1 := set!-print!-precision 3;
- princ "Over "; prin log_count; princ " tests the speed ratio was ";
- print time_ratio;
- princ " (or ";
- prin gc_time_ratio;
- printc " is garbage collection costs are included)";
- set!-print!-precision p1 >>;
- close wrs time_data;
- linelength oll;
- if null files_with_differences then <<
- terpri(); terpri();
- printc "+++++++++++++++++++++++++++";
- printc "+++ All log files match +++";
- printc "+++++++++++++++++++++++++++";
- terpri() >>
- else <<
- terpri(); terpri();
- printc "+++++++++++++++++++++++++++++++";
- printc "+++ The following logs differ:";
- for each x in reverse files_with_differences do <<
- ttab 4; print x >>;
- printc "+++++++++++++++++++++++++++++++";
- terpri() >>;
- end;
- faslend;
- load!-module 'xremake;
- << initreduce();
- date!* := "Bootstrap version";
- preserve('begin, "REDUCE", t) >>;
- symbolic;
- !#if (and (or (boundp 'force_c_code)
- (not (memq 'embedded lispsystem!*)))
- (not !*savedef))
- load!-module 'user;
- !#endif
- get_configuration_data();
- package!-remake2(prolog_file,'support);
- package!-remake2('revision,'support);
- package!-remake2(rend_file,'support);
- package!-remake2('entry,'support);
- package!-remake2('smacros,'support);
- package!-remake2('remake,'support);
- % The next lines have LOTS of hidden depth! They restart CSL repeatedly
- % so that each of the modules that has to be processed gets dealt with in
- % a fresh uncluttered environment. The list of modules is fetched from
- % a configuration file which must have 3 s-expressions in it. The first
- % is a list of basic modules that must be built to get a core version of
- % REDUCE. The second list identifies modules that can be built one the core
- % is ready for use, while the last list indicates which modules have
- % associated test scripts.
- %
- % When the modules have been rebuilt the system does a restart that
- % kicks it back into REDUCE by calling begin(). This then continues
- % reading from the stream that had been the standard input when this
- % job started. Thus this script MUST be invoked as
- % ./csl -obootstrapreduce.img -z buildreduce.lsp
- % with the file buildreduce.lsp specified on the command line in the call. It
- % will not work if you start csl manually and then do a (rdf ..) [say]
- % on buildreduce.lsp. I told you that it was a little delicate.
- !#if !*savedef
- % Some switches may be in the utter core and not introduced via the
- % "switch" declaration...
- for each y in oblist() do
- if flagp(y, 'switch) then <<
- princ "+++ Declaring a switch: ";
- print y >>;
- !#endif
- get_configuration_data();
- build_reduce_modules reduce_base_modules;
- % Now I want to do a cold-start so that I can create a sensible
- % image for use in the subsequent build steps. This image should not
- % contain ANYTHING extraneous.
- symbolic restart!-csl nil;
- (cond
- ((eq 'vsl (car lispsystem!*)) (rdf "$srcdir/vsl.lsp")))
- (setq !*savedef (and (or (boundp 'bootstrap)
- (null (memq 'embedded lispsystem!*)))
- (zerop (cdr (assoc 'c!-code lispsystem!*)))))
- (make!-special '!*noinlines)
- (prog (w)
- (setq w (errorset 'noinlines nil nil))
- (setq !*noinlines (and (not (atom w)) (car w)))
- (print (list '!*noinlines 'set 'to !*noinlines)))
- (make!-special '!*native_code)
- (setq !*native_code nil)
- (setq !*backtrace t)
- (cond ((and (null !*savedef)
- (or (boundp 'force_c_code) (null (memq 'embedded lispsystem!*))))
- (load!-module 'user)))
- (load!-module 'cslcompat)
- (setq !*comp nil)
- (load!-module 'module) % Definition of load_package, etc.
- (load!-module 'cslprolo) % CSL specific code.
- (setq loaded!-packages!* '(cslcompat user cslprolo))
- (load!-package 'revision)
- (load!-package 'rlisp)
- (load!-package 'cslrend)
- (load!-package 'smacros)
- (load!-package 'poly)
- (load!-package 'arith)
- (load!-package 'alg)
- (load!-package 'mathpr)
- (cond
- ((modulep 'tmprint) (load!-package 'tmprint)))
- (load!-package 'entry)
- (setq version!* (compress (cons '!"
- (append
- (explodec "Reduce (Free CSL version, revision ")
- (append (explodec revision!*) (explodec ")"""))))))
- (setq date!* (date))
- (setq !*backtrace nil)
- (initreduce)
- (setq no_init_file nil)
- % restart-csl re-applied the -D@srcdir=<DIR> -D@reduce=<DIR> command-line
- % options and as a consequence the variables !@srcdir and !@reduce will be
- % set here. This is perhaps convenient for people who run Reduce with the
- % binaries sitting exactly where they where originally built, or at least
- % on a computer where the path to the source files used to build Reduce still
- % being valid. It would however be a MESS to try to rely on these on (for
- % instance) another machine. I had thus considered the line
- % (setq !@csl (setq !@reduce (symbol!-value (gensym))))
- % which is intende to unset those variables so leaving things clean. However
- % some developers really like to be able to do incremental builds to Reduce
- % and so to help them I will leave things as they are and also ensure
- % that everything is ready for package!-remake. I am not 100% happy about this
- % since I view it as supporting and hence encouraging practises that I count
- % as delicate (especially as regards built vs installed Reduce and dependencies
- % between modules) so I still HOPE that most people who are developing
- % stuff will rebuild Reduce from scratch rather often.
- (load!-package 'xremake)
- (get_configuration_data)
- % If the user compiles a new FASL module then I will let it
- % generate native code by default. I build the bulk of REDUCE
- % without that since I have statically-selected hot-spot compilation
- % that gives me what I believe to be a better speed/space tradeoff.
- % Oh well, let's change that and disable it by default since at least on
- % windows there are problems with windows vs cygwin file-names.
- (fluid '(!*native_code))
- (setq !*native_code nil) % The native compilation option that I was
- % considering at one stage is no longer available.
- (preserve 'begin (bldmsg "%w, %w ..." version!* date!*) t)
- % Note that (preserve) here arranges to reload the image that it
- % creates, and it then runs (begin) the start-up function. This will
- % leave us running Reduce in algebraic mode...
- %
- % See the fairly length comments given a bit earlier about the
- % delicacy of the next few lines!
- %
- symbolic;
- no_init_file := t;
- load!-module 'xremake;
- get_configuration_data();
- build_reduce_modules reduce_extra_modules;
- symbolic;
- "**** **** REDUCE FULLY REBUILD **** ****";
- % At this stage I have a complete workable REDUCE. If built using a
- % basic CSL (I call it "bootstrapreduce" here) nothing has been compiled into
- % C (everything is bytecoded), and it is big because it has retained all
- % Lisp source code in the image file. If however I built using a version
- % of CSL ("reduce") that did have things compiled into C then these will
- % be exploited and the original Lisp source will be omitted from the
- % image, leaving a production version.
- lisp stop(0);
- bye;
|