Return to scanner.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / fp

Annotation of 42BSD/ucb/fp/scanner.l, revision 1.1

1.1     ! root        1: (setq SCCS-scanner.l "@(#)scanner.l    1.1     4/27/83")
        !             2: ;  FP interpreter/compiler
        !             3: ;  Copyright (c) 1982  Scott B. Baden
        !             4: ;  Berkeley, California
        !             5: 
        !             6: ; Scanner code.
        !             7: 
        !             8: ; get the next token: names, numbers, special symbols
        !             9: ; this is the top-level scanner section.
        !            10: 
        !            11: (include specials.l)
        !            12: (declare (localf alpha$ numer$ get_num$ get_nam$ namtyp two_kind))
        !            13: 
        !            14: (defun get_tkn nil
        !            15:   (do ((char_num (Getc) (Getc))
        !            16:        (scan_fn nil))
        !            17:       
        !            18:       ((eq char_num -1) (*throw 'parse$err 'eof$$))            ; eof control D
        !            19:       
        !            20:       ; if the first character is a letter then the next token is a name
        !            21:       
        !            22:       (cond ((alpha$ char_num) (return (namtyp char_num)))
        !            23:            
        !            24:            ; if the first character is a number then next token is a number 
        !            25:            
        !            26:            ((numer$ char_num) (return 
        !            27:                                (list 'select$$
        !            28:                                      (get_num$ char_num))))
        !            29:            
        !            30:            ((memq char_num #.whiteSpace))
        !            31:            ((eq char_num 35) (clr_teol))       ; # is the comment char.
        !            32:            (t (setq scan_fn (get char_set (ascii char_num)))
        !            33:               (cond ((null scan_fn)
        !            34:                      (*throw 'parse$err `(err$$ bad_char ,(ascii char_num))))
        !            35:                     (t (return (funcall scan_fn))))))))
        !            36:           
        !            37: ; these are the scanner action functions
        !            38: 
        !            39: 
        !            40: (defun (scan$asc |[|) nil
        !            41:   'lbrack$$)
        !            42: 
        !            43: (defun (scan$asc |]|) nil
        !            44:   'rbrack$$)
        !            45: 
        !            46: (defun (scan$asc |{|) nil
        !            47:   'lbrace$$)
        !            48: 
        !            49: (defun (scan$asc |}|) nil
        !            50:   'rbrace$$)
        !            51: 
        !            52: (defun (scan$asc |(|) nil
        !            53:   'lparen$$)
        !            54: 
        !            55: (defun (scan$asc |)|) nil
        !            56:   'rparen$$)
        !            57: 
        !            58: (defun (scan$asc |@|) nil
        !            59:   'compos$$)
        !            60: 
        !            61: (defun (scan$asc |!|) nil
        !            62:   'insert$$)
        !            63: 
        !            64: (defun (scan$asc |\||) nil ; tree insert
        !            65:   'ti$$)
        !            66: 
        !            67: (defun (scan$asc |&|) nil
        !            68:   'alpha$$)
        !            69: 
        !            70: (defun (scan$asc |;|) nil
        !            71:   'semi$$)
        !            72: 
        !            73: (defun (scan$asc |:|) nil
        !            74:   'colon$$)
        !            75: 
        !            76: (defun (scan$asc |,|) nil
        !            77:   'comma$$)
        !            78: 
        !            79: 
        !            80: (defun (scan$asc |+|) nil                      ; plus or pos select
        !            81:   (cond ((numer$ (peekc)) (list 'select$$ (get_num$ #/0)))
        !            82:        (t '(builtin$$ plus))))
        !            83:   
        !            84:   
        !            85: (defun (scan$asc |*|) nil
        !            86:   '(builtin$$ times))
        !            87: 
        !            88: (defun (scan$asc |/|) nil
        !            89:   '(builtin$$ div))
        !            90: 
        !            91: (defun (scan$asc |=|) nil
        !            92:   '(builtin$$ eq))
        !            93: 
        !            94:   
        !            95:   ; either a 1 or 2-char token
        !            96: (defun (scan$asc |-|) nil
        !            97:   (cond ((numer$ (peekc))                              ; subtract or neg select
        !            98:         (list 'select$$ (minus (get_num$ #/0))))
        !            99:        (t (two_kind #/> 'arrow$$ '(builtin$$ sub)))))  ; or arrow
        !           100:   
        !           101: (defun (scan$asc |>|) nil                              ; > or >=
        !           102:   (two_kind #/= '(builtin$$ ge) '(builtin$$ gt)))
        !           103: 
        !           104: (defun (scan$asc |<|) nil                               ; < or <=
        !           105:   (two_kind #/= '(builtin$$ le) '(builtin$$ lt)))
        !           106: 
        !           107: (defun (scan$asc |~|) nil                              ; ~= or error
        !           108:   (two_kind #/= '(builtin$$ ne)
        !           109:            `(badtkn$$ ,(ascii char_num))))
        !           110:   
        !           111:   
        !           112:   ; if a % then read in the next constant (object)
        !           113: 
        !           114: (defun (scan$asc |%|) nil
        !           115:   (let ((v (get_obj nil)))
        !           116:        (list 'constant$$ (list 'quote v))))
        !           117:   
        !           118: 
        !           119: ; these are the  support routines 
        !           120: 
        !           121: ; routine to tell if a character is a letter
        !           122: 
        !           123: (defun alpha$ (x)
        !           124:   (or (and (greaterp x 96) (lessp x 123))
        !           125:       (and (greaterp x 64) (lessp x 91))))
        !           126: 
        !           127: 
        !           128: ; routine to  tell if character is a number
        !           129: 
        !           130: (defun numer$ (x)
        !           131:   (and (greaterp x 47) (lessp x 58)))
        !           132: 
        !           133: 
        !           134: ; routine to read in a number 
        !           135: 
        !           136: (defun get_num$  (first_c)
        !           137:   (do ((num$ (diff first_c 48 ))
        !           138:        (c (peekc) (peekc)))
        !           139:       ((memq c num_delim$) (return num$))
        !           140:       (cond ((not (numer$ c)) (*throw 'parse$err  '(err$$ badnum)))
        !           141:            (t (setq num$ (plus (times 10 num$) (diff (Getc) 48 )))))))
        !           142: 
        !           143: 
        !           144: 
        !           145: ; routine to read in a name
        !           146: 
        !           147: (defun get_nam$ (first_c)
        !           148:   (do ((name$ (cons first_c nil))
        !           149:        (c (peekc) (peekc)))
        !           150:       ((not (or (numer$ c) (alpha$ c) (eq #/_ c))) (implode (nreverse name$)))
        !           151:       (setq name$ (cons (Getc) name$))))
        !           152: 
        !           153: ; routine to determine whether the name represents a builtin
        !           154: ; or not
        !           155: 
        !           156: (defun namtyp (c)
        !           157:   (let ((x (get_nam$ c)))
        !           158:        (cond ((eq x 'while) 'while$$)
        !           159:             (t (list 
        !           160:                 (cond ((null (memq x builtins)) 'defined$$)
        !           161:                       (t 'builtin$$)) x)))))
        !           162: 
        !           163: 
        !           164: ; read in a lisp sequence
        !           165: 
        !           166: (defun readit nil
        !           167:   (If (not (memq (car in_buf) '(< % :)))
        !           168:       then (setq in_buf (cons 32 in_buf)))
        !           169: 
        !           170:   (setq in_buf (cons #/< in_buf))
        !           171:   (cond ((and ptport (null infile)) (patom '< ptport)))
        !           172:   (let ((readtable newreadtable))
        !           173:        (do ((xx (*catch 'parse$err  (get_obj t)) (*catch  'parse$err (get_obj t)))
        !           174:            (result nil))
        !           175:           ((eq xx '>) (nreverse result))
        !           176: 
        !           177:           (cond ((find 'err$$ xx) (*throw 'parse$err `(err$$ bad_obj ,xx))))
        !           178:           (cond ((eq '\, xx))
        !           179:                 (t (setq result (cons xx result)))))))
        !           180: 
        !           181: 
        !           182: ; peek ahead to see if the single character token in really
        !           183: ; a double character token
        !           184: 
        !           185: (defun two_kind (char2 dbl_nm sing_nm)
        !           186:   (cond ((eq (peekc) char2)
        !           187:         (prog (dummy)
        !           188:               (setq dummy (Getc)) (return dbl_nm)))
        !           189:        (t sing_nm)))
        !           190: 
        !           191: ; check if any ? (bottom) in sequence
        !           192: 
        !           193: (defun chk_bot$ (x)
        !           194:   (cond ((atom x) (eq x '?))
        !           195:        (t (or (chk_bot$ (car x)) (chk_bot$ (cdr x))))))
        !           196: 
        !           197: ; get an object and check for bottom (?) or errors (reserved symbols)
        !           198: 
        !           199: (defun get_obj (read_seq)
        !           200:   (let ((readtable newreadtable))
        !           201:        (prog (x)
        !           202:             (setq x (read_inp))
        !           203:             (cond ((chk_bot$ x) (return '?))
        !           204:                   ((boolp x) (return x))
        !           205:                   ((and (atom x) (memq x '(|,| |>|)))
        !           206:                    (cond (read_seq (return x))
        !           207:                          (t (*throw 'parse$err  '(err$$ bad_comma)))))
        !           208:                   ((and (atom x) (memq x '(+ -)))
        !           209:                    (cond ((numer$ (peekc))
        !           210:                           (let ((z (*catch 'parse$err (get_obj nil))))
        !           211:                                (cond ((find 'err$$ z)
        !           212:                                       (*throw 'parse$err `(err$$ bad_num ,z)))
        !           213:                                      ((not (numberp z))
        !           214:                                       (*throw 'parse$err `(err$$ bad_num ,z)))
        !           215:                                      (t (cond ((eq x '+) (return z))
        !           216:                                               (t (return (diff z))))))))
        !           217:                          (t (*throw 'parse$err `(err$$ bad_num ,x)))))
        !           218:                   ((and (symbolp x) (numer$ (car (exploden x))))
        !           219:                    (*throw 'parse$err `(err$$ bad_num ,x)))
        !           220:                   ((and (atom x) (memq x e_rsrvd)) (*throw 'parse$err `(err$$ bad_obj ,x)))
        !           221:                   (t (return x))))))
        !           222: 
        !           223: 
        !           224: (defun read_inp nil
        !           225:   (let ((c
        !           226:         (let ((piport infile))
        !           227:              (Read))))
        !           228:        (If (not (listp c))
        !           229:           then (let ((ob (exploden c)))
        !           230:                     (let ((OB
        !           231:                            (If (and (not (= (car in_buf) #/<))
        !           232:                                     (not (= (car in_buf) #/>))
        !           233:                                     (not (= c '>)))
        !           234:                                then (cons 32 ob)
        !           235:                                else ob)))
        !           236:                          
        !           237:                          (If (onep (length OB))
        !           238:                              then (setq in_buf (cons (car OB) in_buf))
        !           239:                              else (setq in_buf (append (reverse OB) in_buf))))))
        !           240:        c))
        !           241: 
        !           242: 
        !           243: 
        !           244: (defun clr_teol nil
        !           245:   (let ((piport infile))
        !           246:        (do ((c (Getc) (Getc)))
        !           247:           ((eq c #.CR) 
        !           248:            (cond ((not in_def) (setq in_buf nil)))
        !           249:            (cond ((and (not infile) (not in_def)) 
        !           250:                   (patom "      ")))))))
        !           251: 
        !           252: (defun p_strng (s)
        !           253:   (patom (ascii s)))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.