Return to scanner.l CVS log

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

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

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

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