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