1 (setq SCCS-runFp.l "@(#)runFp.l 1.2 04/29/83") 2 ; FP interpreter/compiler 3 ; Copyright (c) 1982 Scott B. Baden 4 ; Berkeley, California 5 6 ; FASL (or load if no object files exist) then run FP. 7 ; also set up user-top-level to 'runFp'. 8 9 (include specials.l) 10 11 (declare 12 (localf make_chset setup init addHelp initHelp) 13 (special user-top-level)) 14 15 (sstatus translink on) 16 17 (mapcar 'load 18 '(fpMain handlers scanner parser codeGen primFp utils fpPP fpMeasures)) 19 20 21 (defun runFp nil 22 (cond ((null (make_chset)) 23 (patom "Illegal Character set") 24 (terpri) 25 (exit)) 26 27 (t 28 (setup) ; set up FP syntax funnies 29 (init) 30 (Tyi) 31 (msg N "FP, v. 4.2, (4/28/83)" N (B 6)))) 32 33 (setq user-top-level 'res_fp) ; from now on just resume FP-- 34 ; no need for extensive initializations 35 36 (signal 2 'break-resp) 37 (fpMain nil t)) ; invoke fp, exit to shell when done 38 39 (defun res_fp nil ; restart fp after infinite recursion, 40 ; simpler initializatin than runFp. 41 (signal 2 'break-resp) 42 (msg N (B 6)) 43 (setq in_def nil infile nil outfile nil fn_name 'tmp$$ in_buf nil) 44 (setq level 0) 45 (fpMain nil t)) 46 47 48 (defun make_chset nil 49 (putprop 'fonts "+-,>!%&*/:=@{}()[]?~TF;#" 'asc) 50 (cond ((null (setq rsrvd (get 'fonts char_set)))) 51 (t (setq e_rsrvd (explodec rsrvd))))) 52 53 54 (defun setup nil 55 (setq newreadtable (makereadtable nil)) 56 (let ((readtable newreadtable)) 57 (mapcar '(lambda (z) (setsyntax z 66)) (exploden rsrvd)) 58 (setsyntax #/< 'macro 'readit)) 59 60 (setsyntax #/< 'macro 'readit)) 61 62 63 (defun init nil 64 ; these are the only chars which may delimit numbers 65 ; (select operator) 66 67 (setq num_delim$ '(#/, #/] #/@ #/: #/} 41 59 32 9 10 #/-)) 68 69 (setq timeIt nil) 70 (setq char_set (concat 'scan$ char_set)) 71 (setq in_def nil) 72 (setq infile nil) 73 (setq outfile nil) 74 (setq fn_name 'tmp$$) 75 (setq in_buf nil) 76 (setq level 0) ; initialize level to 0 77 (setq TracedFns nil) ; just to make sure TracedFns is defined 78 (setq DynTraceFlg nil) ; default of no dynamic tracing 79 80 81 82 ; These are the builtin function names 83 84 (setq builtins 85 '( 86 out ; output fn - for debug only 87 tl ; left tail 88 id ; id 89 atom ; atom 90 eq ; equal 91 not ; not 92 and ; and 93 or ; or 94 xor ; xor 95 null ; null 96 iota ; counting sequence generator 97 ; (library functions) 98 sin 99 asin 100 cos 101 acos 102 log ; natural 103 exp 104 mod 105 ; (unary origin) 106 first ; the first element 107 last ; the last element 108 front ; all except last 109 pick ; get nth element 110 concat ; concat 111 pair ; makes pairs 112 split ; splits into two 113 reverse ; reverse 114 distl ; distribute left 115 distr ; distribute right 116 length ; length 117 trans ; transpose 118 while ; while 119 apndl ; append left 120 apndr ; append right 121 tlr ; right tail 122 rotl ; rotate left 123 rotr)) ; rotate right 124 125 (initStats) 126 (initHelp)) 127 128 (defun addHelp (text cmd) 129 (putprop 'helpCmd text cmd)) 130 131 (defun initHelp nil 132 (addHelp "fsave <file> Same as csave except without pretty-printing" 'fsave) 133 (addHelp "cload <file> Load Lisp code from a file (may be compiled)" 'cload) 134 (addHelp "csave <file> Output Lisp code for all user-defined fns" 'csave) 135 (addHelp "debug on/off Turn debugger output on/off" 'debug) 136 (addHelp "lisp Exit to the lisp system (return with '^D')" 'help) 137 (addHelp "help This text" 'help) 138 (addHelp "script open/close/append [file] Open or close a script-file" 'script) 139 (addHelp "timer on/off Turn timer on/off" 'timing) 140 (addHelp "trace on/off <fn1> ... Start/Stop exec trace of <fn1> ..." 'trace) 141 (addHelp "stats on/off/reset/print [file] collect and output dynamic stats" 'stats) 142 (addHelp "fns List all functions" 'fns) 143 (addHelp "delete <fn1> ... Delete <fn1> ..." 'delete) 144 (addHelp "pfn <fn1> ... Print source text of <fn1> ..." 'pfn) 145 (addHelp "save <file> Save defined fns in <file>" 'save) 146 (addHelp "load <file> Redirect input from <file>" 'load) 147 ) 148 149 150 (setq user-top-level 'runFp) 151 (setq char_set 'asc) ; set to the type of character set 152 ; desired at the moment only ascii (asc) 153 ; supported (no APL at this time). 154 155